e51e3c031f09936f713036c461b07676bfeb9bb3
[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 point->tile
51
52 animation-frame?
53 animation-frame-tile
54 animation-frame-duration
55
56 tile?
57 tile-id
58 tile-animation
59 tile-properties
60
61 tileset?
62 tileset-name
63 tileset-first-gid
64 tileset-size
65 tileset-tile-width
66 tileset-tile-height
67 tileset-atlas
68 tileset-tiles
69 tileset-properties
70
71 map-tile?
72 map-tile-ref
73 map-tile-rect
74
75 tile-layer?
76 tile-layer-name
77 tile-layer-width
78 tile-layer-height
79 tile-layer-tiles
80 tile-layer-properties
81
82 object-layer?
83 object-layer-name
84 object-layer-objects
85 object-layer-properties
86
87 polygon?
88 polygon-points
89
90 map-object?
91 map-object-id
92 map-object-name
93 map-object-type
94 map-object-shape
95 map-object-properties
96
97 load-tile-map
98 draw-tile-map
99 draw-tile-map*))
100
101 (define-record-type <tile-map>
102 (%make-tile-map orientation width height tile-width tile-height
103 tilesets layers properties rect)
104 tile-map?
105 (orientation tile-map-orientation)
106 (width tile-map-width)
107 (height tile-map-height)
108 (tile-width tile-map-tile-width)
109 (tile-height tile-map-tile-height)
110 (tilesets tile-map-tilesets)
111 (layers tile-map-layers)
112 (properties tile-map-properties)
113 (rect tile-map-rect))
114
115 (define-record-type <animation-frame>
116 (%make-animation-frame tile duration)
117 animation-frame?
118 (tile animation-frame-tile)
119 (duration animation-frame-duration))
120
121 (define-record-type <tile>
122 (%make-tile id texture batch animation properties)
123 tile?
124 (id tile-id)
125 (texture tile-texture)
126 (batch tile-batch)
127 (animation tile-animation)
128 (properties tile-properties))
129
130 (define-record-type <tileset>
131 (%make-tileset name first-gid size tile-width tile-height
132 atlas tiles properties batch)
133 tileset?
134 (name tileset-name)
135 (first-gid tileset-first-gid)
136 (size tileset-size)
137 (tile-width tileset-tile-width)
138 (tile-height tileset-tile-height)
139 (atlas tileset-atlas)
140 (tiles tileset-tiles)
141 (properties tileset-properties)
142 (batch tileset-batch))
143
144 (define-record-type <map-tile>
145 (%make-map-tile tile rect)
146 map-tile?
147 (tile map-tile-ref)
148 (rect map-tile-rect))
149
150 (define-record-type <tile-layer>
151 (%make-tile-layer name width height tiles properties)
152 tile-layer?
153 (name tile-layer-name)
154 (width tile-layer-width)
155 (height tile-layer-height)
156 (tiles tile-layer-tiles)
157 (properties tile-layer-properties))
158
159 (define-record-type <object-layer>
160 (%make-object-layer name objects properties)
161 object-layer?
162 (name object-layer-name)
163 (objects object-layer-objects)
164 (properties object-layer-properties))
165
166 ;; TODO: This should probably be a generic thing that we can use
167 ;; outside of tiled maps.
168 (define-record-type <polygon>
169 (make-polygon points)
170 polygon?
171 (points polygon-points))
172
173 (define-record-type <map-object>
174 (%make-map-object id name type shape properties)
175 map-object?
176 (id map-object-id)
177 (name map-object-name)
178 (type map-object-type)
179 (shape map-object-shape)
180 (properties map-object-properties))
181
182 (define (tile-map-layer-ref tile-map name)
183 "Return the layer named NAME."
184 (define (layer-name layer)
185 (if (tile-layer? layer)
186 (tile-layer-name layer)
187 (object-layer-name layer)))
188 (let ((layers (tile-map-layers tile-map)))
189 (let loop ((i 0))
190 (cond
191 ((= i (vector-length layers))
192 #f)
193 ((string=? name (layer-name (vector-ref layers i)))
194 (vector-ref layers i))
195 (else
196 (loop (+ i 1)))))))
197
198 (define (point->tile tile-map x y)
199 "Translate the pixel coordinates (X, Y) into tile coordinates."
200 (values (floor (/ x (tile-map-tile-width tile-map)))
201 (floor (/ y (tile-map-tile-height tile-map)))))
202
203 (define (load-tile-map file-name)
204 "Load the Tiled TMX formatted map in FILE-NAME."
205 (define map-directory
206 (if (absolute-file-name? file-name)
207 (dirname file-name)
208 (string-append (getcwd) "/" (dirname file-name))))
209 (define (scope file-name)
210 (string-append map-directory "/" file-name))
211 (define* (attr node name #:optional (parse identity))
212 (let ((result ((sxpath `(@ ,name *text*)) node)))
213 (if (null? result)
214 #f
215 (parse (car result)))))
216 (define (parse-color-channel s start)
217 (/ (string->number (substring s start (+ start 2)) 16) 255.0))
218 (define (parse-property node)
219 (let ((name (attr node 'name string->symbol))
220 (type (or (attr node 'type string->symbol) 'string))
221 (value (attr node 'value)))
222 (cons name
223 (match type
224 ((or 'string 'file) value)
225 ('bool (not (string=? value "false")))
226 ((or 'int 'float) (string->number value))
227 ('color
228 (make-color (parse-color-channel value 3)
229 (parse-color-channel value 5)
230 (parse-color-channel value 7)
231 (parse-color-channel value 1)))
232 (_ (error "unsupported property type" type))))))
233 (define (parse-image node)
234 (let ((source (attr node 'source)))
235 (load-image (scope source))))
236 (define (parse-frame node)
237 (let ((tile-id (attr node 'tileid string->number))
238 (duration (attr node 'duration string->number)))
239 ;; TODO: lookup actual tile in tileset
240 (%make-animation-frame tile-id duration)))
241 (define (parse-tile node rows columns atlas batch)
242 (let ((id (attr node 'id string->number))
243 (animation (map parse-frame ((sxpath '(animation frame)) node)))
244 (properties (map parse-property
245 ((sxpath '(properties property)) node))))
246 (%make-tile id (texture-atlas-ref atlas id) batch animation properties)))
247 (define (parse-tiles nodes size columns atlas batch)
248 (let ((table (make-hash-table))
249 (tiles (make-vector size))
250 (rows (/ size columns)))
251 (for-each (lambda (node)
252 (let ((tile (parse-tile node rows columns atlas batch)))
253 (hash-set! table (tile-id tile) tile)))
254 nodes)
255 (let loop ((i 0))
256 (when (< i size)
257 (let ((tile
258 (or (hash-ref table i)
259 (%make-tile i (texture-atlas-ref atlas i) batch #f '()))))
260 (vector-set! tiles i tile))
261 (loop (+ i 1))))
262 tiles))
263 (define (first-gid node)
264 (attr node 'firstgid string->number))
265 (define (parse-internal-tileset node first-gid)
266 (let* ((name (attr node 'name))
267 (tile-width (attr node 'tilewidth string->number))
268 (tile-height (attr node 'tileheight string->number))
269 (margin (or (attr node 'margin string->number) 0))
270 (spacing (or (attr node 'spacing string->number) 0))
271 (columns (attr node 'columns string->number))
272 (size (attr node 'tilecount string->number))
273 (texture (parse-image ((sxpath '(image)) node)))
274 (atlas (split-texture texture tile-width tile-height
275 #:margin margin #:spacing spacing))
276 (batch (make-sprite-batch texture))
277 (tiles (parse-tiles ((sxpath '(tile)) node) size columns atlas batch))
278 (properties (map parse-property
279 ((sxpath '(properties property)) node))))
280 (%make-tileset name first-gid size tile-width tile-height
281 atlas tiles properties batch)))
282 (define (parse-external-tileset node)
283 (let* ((first-gid (attr node 'firstgid string->number))
284 (source (scope (attr node 'source)))
285 (tree (call-with-input-file source xml->sxml)))
286 (parse-internal-tileset (car ((sxpath '(tileset)) tree)) first-gid)))
287 (define (parse-tileset node)
288 (if (attr node 'source)
289 (parse-external-tileset node)
290 (parse-internal-tileset node (first-gid node))))
291 (define (tile-gid->map-tile raw-gid tilesets x y tile-width tile-height)
292 ;; The top 3 bits of the tile gid are flags for various types of
293 ;; flipping.
294 ;;
295 ;; TODO: Respect the flipping settings.
296 (let* ((flipped-horizontally? (> (logand raw-gid #x80000000) 0))
297 (flipped-vertically? (> (logand raw-gid #x40000000) 0))
298 (flipped-diagonally? (> (logand raw-gid #x20000000) 0))
299 ;; Remove the upper 3 bits to get the true tile id.
300 (gid (logand raw-gid #x1FFFFFFF))
301 (tileset (find (lambda (t)
302 (and (>= gid (tileset-first-gid t))
303 (< gid (+ (tileset-first-gid t)
304 (tileset-size t)))))
305 tilesets))
306 (tw (tileset-tile-width tileset))
307 (th (tileset-tile-height tileset)))
308 (%make-map-tile (vector-ref (tileset-tiles tileset)
309 (- gid (tileset-first-gid tileset)))
310 (make-rect (* x tw) (* y th) tw th))))
311 (define (tile-gids->map-tiles gids width height tilesets)
312 (let ((tiles (make-vector (* width height))))
313 (let y-loop ((y 0)
314 (rows (reverse gids))) ; invert y
315 (when (< y height)
316 (match rows
317 ((row . rest)
318 (let x-loop ((x 0)
319 (columns row))
320 (when (< x width)
321 (match columns
322 ((gid . rest)
323 (vector-set! tiles
324 (+ (* width y) x)
325 (if (zero? gid)
326 #f
327 (tile-gid->map-tile gid tilesets
328 x y width height)))
329 (x-loop (+ x 1) rest)))))
330 (y-loop (+ y 1) rest)))))
331 tiles))
332 (define (parse-csv lines width height tilesets)
333 (let ((gids (map (lambda (line)
334 (filter-map (lambda (s)
335 (and (not (string-null? s))
336 (string->number s)))
337 (string-split line #\,)))
338 (take (drop (string-split lines #\newline) 1) height))))
339 (tile-gids->map-tiles gids width height tilesets)))
340 (define (parse-layer-data node width height tilesets)
341 (let ((encoding (attr node 'encoding string->symbol))
342 (data (car ((sxpath '(*text*)) node))))
343 (match encoding
344 ('csv (parse-csv data width height tilesets))
345 (_ (error "unsupported tile layer encoding" encoding)))))
346 (define (parse-tile-layer node tilesets)
347 (let* ((name (attr node 'name))
348 (width (attr node 'width string->number))
349 (height (attr node 'height string->number))
350 (tiles (parse-layer-data ((sxpath '(data)) node)
351 width height tilesets))
352 (properties (map parse-property
353 ((sxpath '(properties property)) node))))
354 (%make-tile-layer name width height tiles properties)))
355 (define (parse-polygon node pixel-height)
356 (make-polygon
357 (list->vector
358 (map (lambda (s)
359 (match (string-split s #\,)
360 ((x y)
361 (vec2 (string->number x)
362 (- pixel-height (string->number y))))))
363 (string-split (attr node 'points) #\space)))))
364 (define (parse-object node pixel-height)
365 (let* ((id (attr node 'id string->number))
366 (name (attr node 'name))
367 (type (attr node 'type string->symbol))
368 (x (attr node 'x string->number))
369 (y (- pixel-height (attr node 'y string->number)))
370 (width (attr node 'width string->number))
371 (height (attr node 'height string->number))
372 (shape (if (and width height)
373 (make-rect x y width height)
374 (parse-polygon (car ((sxpath '(polygon)) node))
375 pixel-height)))
376 (properties (map parse-property
377 ((sxpath '(properties property)) node))))
378 (%make-map-object id name type shape properties)))
379 (define (parse-object-layer node pixel-height)
380 (let ((name (attr node 'name))
381 (objects (map (lambda (node)
382 (parse-object node pixel-height))
383 ((sxpath '(object)) node)))
384 (properties (map parse-property
385 ((sxpath '(properties property)) node))))
386 (%make-object-layer name objects properties)))
387 (let* ((tree (call-with-input-file file-name xml->sxml))
388 (m ((sxpath '(map)) tree))
389 (version (let ((version (attr m 'version)))
390 (unless (any (lambda (v) (string=? version v)) '("1.0" "1.1" "1.2"))
391 (error "unsupported tiled map format version" version))
392 version))
393 (orientation (attr m 'orientation string->symbol))
394 (width (attr m 'width string->number))
395 (height (attr m 'height string->number))
396 (tile-width (attr m 'tilewidth string->number))
397 (tile-height (attr m 'tileheight string->number))
398 (properties ((sxpath '(map properties property)) tree))
399 (tilesets (map parse-tileset ((sxpath '(map tileset)) tree)))
400 (layers ((node-or (sxpath '(map layer))
401 (sxpath '(map objectgroup)))
402 tree)))
403 (%make-tile-map orientation width height tile-width tile-height
404 tilesets
405 (list->vector
406 (map (lambda (node)
407 (match node
408 (('layer . _)
409 (parse-tile-layer node tilesets))
410 (('objectgroup . _)
411 (parse-object-layer node (* height tile-height)))))
412 layers))
413 (map parse-property properties)
414 (make-rect 0.0
415 0.0
416 (* width tile-width)
417 (* height tile-height)))))
418
419
420 (define (draw-tile-layer layer matrix x1 y1 x2 y2)
421 (let ((width (tile-layer-width layer))
422 (height (tile-layer-height layer)))
423 (let y-loop ((y y1))
424 (when (< y y2)
425 (let x-loop ((x x1))
426 (when (< x x2)
427 (let ((tile (vector-ref (tile-layer-tiles layer)
428 (+ (* y width) x))))
429 (when tile
430 (let ((tref (map-tile-ref tile)))
431 (sprite-batch-add* (tile-batch tref)
432 (map-tile-rect tile)
433 matrix
434 #:texture-region (tile-texture tref)))))
435 (x-loop (+ x 1))))
436 (y-loop (+ y 1))))))
437
438 (define* (draw-tile-map* tile-map matrix region #:key layers)
439 ;; Calculate the tiles that are visible so we don't waste time
440 ;; drawing unnecessary sprites.
441 (let* ((w (tile-map-width tile-map))
442 (h (tile-map-height tile-map))
443 (tw (tile-map-tile-width tile-map))
444 (th (tile-map-tile-height tile-map))
445 (rx (rect-x region))
446 (ry (rect-y region))
447 (rw (rect-width region))
448 (rh (rect-height region))
449 (x1 (max (inexact->exact (floor (/ rx tw))) 0))
450 (y1 (max (inexact->exact (floor (/ ry th))) 0))
451 (x2 (min (inexact->exact (ceiling (/ (+ rx rw) tw))) w))
452 (y2 (min (inexact->exact (ceiling (/ (+ ry rh) th))) h)))
453 (vector-for-each (lambda (i layer)
454 (when (and (tile-layer? layer)
455 (or (not layers)
456 (memv i layers)))
457 (for-each (lambda (tileset)
458 (sprite-batch-clear! (tileset-batch tileset)))
459 (tile-map-tilesets tile-map))
460 (draw-tile-layer layer matrix x1 y1 x2 y2)
461 (for-each (lambda (tileset)
462 (draw-sprite-batch (tileset-batch tileset)))
463 (tile-map-tilesets tile-map))))
464 (tile-map-layers tile-map))))
465
466 (define %null-vec2 (vec2 0.0 0.0))
467 (define %default-scale (vec2 1.0 1.0))
468 (define %matrix (make-null-matrix4))
469 (define %region (make-rect 0.0 0.0 0.0 0.0))
470
471 ;; Make a default region that is as big as the viewport.
472 (define (default-region tile-map position)
473 (let ((vp (current-viewport)))
474 (set-rect-x! %region (- (vec2-x position)))
475 (set-rect-y! %region (- (vec2-y position)))
476 (set-rect-width! %region (viewport-width vp))
477 (set-rect-height! %region (viewport-height vp))
478 %region))
479
480 (define* (draw-tile-map tile-map
481 #:key
482 layers
483 (position %null-vec2)
484 (region (default-region tile-map position))
485 (origin %null-vec2)
486 (scale %default-scale)
487 (rotation 0.0))
488 "Draw TILE-MAP. By default, all layers are drawn. The LAYERS
489 argument may be used to specify a list of layers to draw, instead."
490 (matrix4-2d-transform! %matrix
491 #:origin origin
492 #:position position
493 #:rotation rotation
494 #:scale scale)
495 (draw-tile-map* tile-map %matrix region #:layers layers))