render: Change texture origin to top-left.
[chickadee.git] / chickadee / render / tiled.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2018 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; Chickadee is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published
6 ;;; by the Free Software Foundation, either version 3 of the License,
7 ;;; or (at your option) any later version.
8 ;;;
9 ;;; Chickadee is distributed in the hope that it will be useful, but
10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 ;;; Commentary:
19 ;;
20 ;; Tiled map format parser and renderer.
21 ;;
22 ;;; Code:
23
24 (define-module (chickadee render tiled)
25 #:use-module (chickadee math matrix)
26 #:use-module (chickadee math rect)
27 #:use-module (chickadee math vector)
28 #:use-module (chickadee render)
29 #:use-module (chickadee render color)
30 #:use-module (chickadee render sprite)
31 #:use-module (chickadee render texture)
32 #:use-module (chickadee render viewport)
33 #:use-module (ice-9 match)
34 #:use-module (srfi srfi-1)
35 #:use-module (srfi srfi-9)
36 #:use-module (srfi srfi-43)
37 #:use-module (sxml simple)
38 #:use-module (sxml xpath)
39 #:export (tile-map?
40 tile-map-orientation
41 tile-map-width
42 tile-map-height
43 tile-map-tile-width
44 tile-map-tile-height
45 tile-map-tilesets
46 tile-map-layers
47 tile-map-properties
48 tile-map-rect
49 tile-map-layer-ref
50
51 animation-frame?
52 animation-frame-tile
53 animation-frame-duration
54
55 tile?
56 tile-id
57 tile-animation
58 tile-properties
59
60 tileset?
61 tileset-name
62 tileset-first-gid
63 tileset-size
64 tileset-tile-width
65 tileset-tile-height
66 tileset-atlas
67 tileset-tiles
68 tileset-properties
69
70 map-tile?
71 map-tile-ref
72 map-tile-rect
73
74 tile-layer?
75 tile-layer-name
76 tile-layer-width
77 tile-layer-height
78 tile-layer-tiles
79 tile-layer-properties
80
81 object-layer?
82 object-layer-name
83 object-layer-objects
84 object-layer-properties
85
86 polygon?
87 polygon-points
88
89 map-object?
90 map-object-id
91 map-object-name
92 map-object-type
93 map-object-shape
94 map-object-properties
95
96 load-tile-map
97 draw-tile-map
98 draw-tile-map*))
99
100 (define-record-type <tile-map>
101 (%make-tile-map orientation width height tile-width tile-height
102 tilesets layers properties rect)
103 tile-map?
104 (orientation tile-map-orientation)
105 (width tile-map-width)
106 (height tile-map-height)
107 (tile-width tile-map-tile-width)
108 (tile-height tile-map-tile-height)
109 (tilesets tile-map-tilesets)
110 (layers tile-map-layers)
111 (properties tile-map-properties)
112 (rect tile-map-rect))
113
114 (define-record-type <animation-frame>
115 (%make-animation-frame tile duration)
116 animation-frame?
117 (tile animation-frame-tile)
118 (duration animation-frame-duration))
119
120 (define-record-type <tile>
121 (%make-tile id texture animation properties)
122 tile?
123 (id tile-id)
124 (texture tile-texture)
125 (animation tile-animation)
126 (properties tile-properties))
127
128 (define-record-type <tileset>
129 (%make-tileset name first-gid size tile-width tile-height
130 atlas tiles properties)
131 tileset?
132 (name tileset-name)
133 (first-gid tileset-first-gid)
134 (size tileset-size)
135 (tile-width tileset-tile-width)
136 (tile-height tileset-tile-height)
137 (atlas tileset-atlas)
138 (tiles tileset-tiles)
139 (properties tileset-properties))
140
141 (define-record-type <map-tile>
142 (%make-map-tile tile rect)
143 map-tile?
144 (tile map-tile-ref)
145 (rect map-tile-rect))
146
147 (define-record-type <tile-layer>
148 (%make-tile-layer name width height tiles properties)
149 tile-layer?
150 (name tile-layer-name)
151 (width tile-layer-width)
152 (height tile-layer-height)
153 (tiles tile-layer-tiles)
154 (properties tile-layer-properties))
155
156 (define-record-type <object-layer>
157 (%make-object-layer name objects properties)
158 object-layer?
159 (name object-layer-name)
160 (objects object-layer-objects)
161 (properties object-layer-properties))
162
163 ;; TODO: This should probably be a generic thing that we can use
164 ;; outside of tiled maps.
165 (define-record-type <polygon>
166 (make-polygon points)
167 polygon?
168 (points polygon-points))
169
170 (define-record-type <map-object>
171 (%make-map-object id name type shape properties)
172 map-object?
173 (id map-object-id)
174 (name map-object-name)
175 (type map-object-type)
176 (shape map-object-shape)
177 (properties map-object-properties))
178
179 (define (tile-map-layer-ref tile-map name)
180 "Return the layer named NAME."
181 (define (layer-name layer)
182 (if (tile-layer? layer)
183 (tile-layer-name layer)
184 (object-layer-name layer)))
185 (let ((layers (tile-map-layers tile-map)))
186 (let loop ((i 0))
187 (cond
188 ((= i (vector-length layers))
189 #f)
190 ((string=? name (layer-name (vector-ref layers i)))
191 (vector-ref layers i))
192 (else
193 (loop (+ i 1)))))))
194
195 (define (load-tile-map file-name)
196 "Load the Tiled TMX formatted map in FILE-NAME."
197 (define map-directory
198 (if (absolute-file-name? file-name)
199 (dirname file-name)
200 (string-append (getcwd) "/" (dirname file-name))))
201 (define (scope file-name)
202 (string-append map-directory "/" file-name))
203 (define* (attr node name #:optional (parse identity))
204 (let ((result ((sxpath `(@ ,name *text*)) node)))
205 (if (null? result)
206 #f
207 (parse (car result)))))
208 (define (parse-color-channel s start)
209 (/ (string->number (substring s start (+ start 2)) 16) 255.0))
210 (define (parse-property node)
211 (let ((name (attr node 'name string->symbol))
212 (type (or (attr node 'type string->symbol) 'string))
213 (value (attr node 'value)))
214 (cons name
215 (match type
216 ((or 'string 'file) value)
217 ('bool (not (string=? value "false")))
218 ((or 'int 'float) (string->number value))
219 ('color
220 (make-color (parse-color-channel value 3)
221 (parse-color-channel value 5)
222 (parse-color-channel value 7)
223 (parse-color-channel value 1)))
224 (_ (error "unsupported property type" type))))))
225 (define (parse-image node)
226 (let ((source (attr node 'source)))
227 (load-image (scope source))))
228 (define (parse-frame node)
229 (let ((tile-id (attr node 'tileid string->number))
230 (duration (attr node 'duration string->number)))
231 ;; TODO: lookup actual tile in tileset
232 (%make-animation-frame tile-id duration)))
233 (define (parse-tile node rows columns atlas)
234 (let ((id (attr node 'id string->number))
235 (animation (map parse-frame ((sxpath '(animation frame)) node)))
236 (properties (map parse-property
237 ((sxpath '(properties property)) node))))
238 (%make-tile id (texture-atlas-ref atlas id)
239 animation properties)))
240 (define (parse-tiles nodes size columns atlas)
241 (let ((table (make-hash-table))
242 (tiles (make-vector size))
243 (rows (/ size columns)))
244 (for-each (lambda (node)
245 (let ((tile (parse-tile node rows columns atlas)))
246 (hash-set! table (tile-id tile) tile)))
247 nodes)
248 (let loop ((i 0))
249 (when (< i size)
250 (let ((tile
251 (or (hash-ref table i)
252 (%make-tile i (texture-atlas-ref atlas i) #f '()))))
253 (vector-set! tiles i tile))
254 (loop (+ i 1))))
255 tiles))
256 (define (first-gid node)
257 (attr node 'firstgid string->number))
258 (define (parse-internal-tileset node first-gid)
259 (let* ((name (attr node 'name))
260 (tile-width (attr node 'tilewidth string->number))
261 (tile-height (attr node 'tileheight string->number))
262 (margin (or (attr node 'margin string->number) 0))
263 (spacing (or (attr node 'spacing string->number) 0))
264 (columns (attr node 'columns string->number))
265 (size (attr node 'tilecount string->number))
266 (texture (parse-image ((sxpath '(image)) node)))
267 (atlas (split-texture texture tile-width tile-height
268 #:margin margin #:spacing spacing))
269 (tiles (parse-tiles ((sxpath '(tile)) node) size columns atlas))
270 (properties (map parse-property
271 ((sxpath '(properties property)) node))))
272 (%make-tileset name first-gid size tile-width tile-height
273 atlas tiles properties)))
274 (define (parse-external-tileset node)
275 (let* ((first-gid (attr node 'firstgid string->number))
276 (source (scope (attr node 'source)))
277 (tree (call-with-input-file source xml->sxml)))
278 (parse-internal-tileset (car ((sxpath '(tileset)) tree)) first-gid)))
279 (define (parse-tileset node)
280 (if (attr node 'source)
281 (parse-external-tileset node)
282 (parse-internal-tileset node (first-gid node))))
283 (define (tile-gid->map-tile gid tilesets x y tile-width tile-height)
284 (let* ((tileset (find (lambda (t)
285 (and (>= gid (tileset-first-gid t))
286 (< gid (+ (tileset-first-gid t)
287 (tileset-size t)))))
288 tilesets))
289 (tw (tileset-tile-width tileset))
290 (th (tileset-tile-height tileset)))
291 (%make-map-tile (vector-ref (tileset-tiles tileset)
292 (- gid (tileset-first-gid tileset)))
293 (make-rect (* x tw) (* y th) tw th))))
294 (define (tile-gids->map-tiles gids width height tilesets)
295 (let ((tiles (make-vector (* width height))))
296 (let y-loop ((y 0)
297 (rows (reverse gids))) ; invert y
298 (when (< y height)
299 (match rows
300 ((row . rest)
301 (let x-loop ((x 0)
302 (columns row))
303 (when (< x width)
304 (match columns
305 ((gid . rest)
306 (vector-set! tiles
307 (+ (* width y) x)
308 (if (zero? gid)
309 #f
310 (tile-gid->map-tile gid tilesets
311 x y width height)))
312 (x-loop (+ x 1) rest)))))
313 (y-loop (+ y 1) rest)))))
314 tiles))
315 (define (parse-csv lines width height tilesets)
316 (let ((gids (map (lambda (line)
317 (filter-map (lambda (s)
318 (and (not (string-null? s))
319 (string->number s)))
320 (string-split line #\,)))
321 (take (drop (string-split lines #\newline) 1) height))))
322 (tile-gids->map-tiles gids width height tilesets)))
323 (define (parse-layer-data node width height tilesets)
324 (let ((encoding (attr node 'encoding string->symbol))
325 (data (car ((sxpath '(*text*)) node))))
326 (match encoding
327 ('csv (parse-csv data width height tilesets))
328 (_ (error "unsupported tile layer encoding" encoding)))))
329 (define (parse-tile-layer node tilesets)
330 (let* ((name (attr node 'name))
331 (width (attr node 'width string->number))
332 (height (attr node 'height string->number))
333 (tiles (parse-layer-data ((sxpath '(data)) node)
334 width height tilesets))
335 (properties (map parse-property
336 ((sxpath '(properties property)) node))))
337 (%make-tile-layer name width height tiles properties)))
338 (define (parse-polygon node pixel-height)
339 (make-polygon
340 (list->vector
341 (map (lambda (s)
342 (match (string-split s #\,)
343 ((x y)
344 (vec2 (string->number x)
345 (- pixel-height (string->number y))))))
346 (string-split (attr node 'points) #\space)))))
347 (define (parse-object node pixel-height)
348 (let* ((id (attr node 'id string->number))
349 (name (attr node 'name))
350 (type (attr node 'type string->symbol))
351 (x (attr node 'x string->number))
352 (y (- pixel-height (attr node 'y string->number)))
353 (width (attr node 'width string->number))
354 (height (attr node 'height string->number))
355 (shape (if (and width height)
356 (make-rect x y width height)
357 (parse-polygon (car ((sxpath '(polygon)) node))
358 pixel-height)))
359 (properties (map parse-property
360 ((sxpath '(properties property)) node))))
361 (%make-map-object id name type shape properties)))
362 (define (parse-object-layer node pixel-height)
363 (let ((name (attr node 'name))
364 (objects (map (lambda (node)
365 (parse-object node pixel-height))
366 ((sxpath '(object)) node)))
367 (properties (map parse-property
368 ((sxpath '(properties property)) node))))
369 (%make-object-layer name objects properties)))
370 (let* ((tree (call-with-input-file file-name xml->sxml))
371 (m ((sxpath '(map)) tree))
372 (version (let ((version (attr m 'version)))
373 (unless (string=? version "1.0")
374 (error "unsupported tiled map format version" version))
375 version))
376 (orientation (attr m 'orientation string->symbol))
377 (width (attr m 'width string->number))
378 (height (attr m 'height string->number))
379 (tile-width (attr m 'tilewidth string->number))
380 (tile-height (attr m 'tileheight string->number))
381 (properties ((sxpath '(map properties property)) tree))
382 (tilesets (map parse-tileset ((sxpath '(map tileset)) tree)))
383 (layers ((node-or (sxpath '(map layer))
384 (sxpath '(map objectgroup)))
385 tree)))
386 (%make-tile-map orientation width height tile-width tile-height
387 tilesets
388 (list->vector
389 (map (lambda (node)
390 (match node
391 (('layer . _)
392 (parse-tile-layer node tilesets))
393 (('objectgroup . _)
394 (parse-object-layer node (* height tile-height)))))
395 layers))
396 (map parse-property properties)
397 (make-rect 0.0
398 0.0
399 (* width tile-width)
400 (* height tile-height)))))
401
402
403 (define (draw-tile-layer layer matrix x1 y1 x2 y2)
404 (let ((width (tile-layer-width layer))
405 (height (tile-layer-height layer)))
406 (let y-loop ((y y1))
407 (when (< y y2)
408 (let x-loop ((x x1))
409 (when (< x x2)
410 (let ((tile (vector-ref (tile-layer-tiles layer)
411 (+ (* y width) x))))
412 (when tile
413 (draw-sprite* (tile-texture (map-tile-ref tile))
414 (map-tile-rect tile)
415 matrix)))
416 (x-loop (+ x 1))))
417 (y-loop (+ y 1))))))
418
419 (define* (draw-tile-map* tile-map matrix region #:key layers)
420 ;; Calculate the tiles that are visible so we don't waste time
421 ;; drawing unnecessary sprites.
422 (let* ((w (tile-map-width tile-map))
423 (h (tile-map-height tile-map))
424 (tw (tile-map-tile-width tile-map))
425 (th (tile-map-tile-height tile-map))
426 (rx (rect-x region))
427 (ry (rect-y region))
428 (rw (rect-width region))
429 (rh (rect-height region))
430 (x1 (max (inexact->exact (floor (/ rx tw))) 0))
431 (y1 (max (inexact->exact (floor (/ ry th))) 0))
432 (x2 (min (inexact->exact (ceiling (/ (+ rx rw) tw))) w))
433 (y2 (min (inexact->exact (ceiling (/ (+ ry rh) th))) h)))
434 (with-batched-sprites
435 (vector-for-each (lambda (i layer)
436 (when (and (tile-layer? layer)
437 (or (not layers)
438 (memv i layers)))
439 (draw-tile-layer layer matrix x1 y1 x2 y2)))
440 (tile-map-layers tile-map)))))
441
442 (define %null-vec2 (vec2 0.0 0.0))
443 (define %default-scale (vec2 1.0 1.0))
444 (define %matrix (make-null-matrix4))
445 (define %region (make-rect 0.0 0.0 0.0 0.0))
446
447 ;; Make a default region that is as big as the viewport.
448 (define (default-region tile-map position)
449 (let ((vp (current-viewport)))
450 (set-rect-x! %region (- (vec2-x position)))
451 (set-rect-y! %region (- (vec2-y position)))
452 (set-rect-width! %region (viewport-width vp))
453 (set-rect-height! %region (viewport-height vp))
454 %region))
455
456 (define* (draw-tile-map tile-map
457 #:key
458 layers
459 (position %null-vec2)
460 (region (default-region tile-map position))
461 (origin %null-vec2)
462 (scale %default-scale)
463 (rotation 0.0))
464 "Draw TILE-MAP. By default, all layers are drawn. The LAYERS
465 argument may be used to specify a list of layers to draw, instead."
466 (matrix4-2d-transform! %matrix
467 #:origin origin
468 #:position position
469 #:rotation rotation
470 #:scale scale)
471 (draw-tile-map* tile-map %matrix region #:layers layers))