render: tiled: Respect image transparent color values.
[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 (trans (attr node 'trans)))
236 (load-image (scope source)
237 #:transparent-color (and trans (string->color trans)))))
238 (define (parse-frame node)
239 (let ((tile-id (attr node 'tileid string->number))
240 (duration (attr node 'duration string->number)))
241 ;; TODO: lookup actual tile in tileset
242 (%make-animation-frame tile-id duration)))
243 (define (parse-tile node rows columns atlas batch)
244 (let ((id (attr node 'id string->number))
245 (animation (map parse-frame ((sxpath '(animation frame)) node)))
246 (properties (map parse-property
247 ((sxpath '(properties property)) node))))
248 (%make-tile id (texture-atlas-ref atlas id) batch animation properties)))
249 (define (parse-tiles nodes size columns atlas batch)
250 (let ((table (make-hash-table))
251 (tiles (make-vector size))
252 (rows (/ size columns)))
253 (for-each (lambda (node)
254 (let ((tile (parse-tile node rows columns atlas batch)))
255 (hash-set! table (tile-id tile) tile)))
256 nodes)
257 (let loop ((i 0))
258 (when (< i size)
259 (let ((tile
260 (or (hash-ref table i)
261 (%make-tile i (texture-atlas-ref atlas i) batch #f '()))))
262 (vector-set! tiles i tile))
263 (loop (+ i 1))))
264 tiles))
265 (define (first-gid node)
266 (attr node 'firstgid string->number))
267 (define (parse-internal-tileset node first-gid)
268 (let* ((name (attr node 'name))
269 (tile-width (attr node 'tilewidth string->number))
270 (tile-height (attr node 'tileheight string->number))
271 (margin (or (attr node 'margin string->number) 0))
272 (spacing (or (attr node 'spacing string->number) 0))
273 (columns (attr node 'columns string->number))
274 (size (attr node 'tilecount string->number))
275 (texture (parse-image ((sxpath '(image)) node)))
276 (atlas (split-texture texture tile-width tile-height
277 #:margin margin #:spacing spacing))
278 (batch (make-sprite-batch texture))
279 (tiles (parse-tiles ((sxpath '(tile)) node) size columns atlas batch))
280 (properties (map parse-property
281 ((sxpath '(properties property)) node))))
282 (%make-tileset name first-gid size tile-width tile-height
283 atlas tiles properties batch)))
284 (define (parse-external-tileset node)
285 (let* ((first-gid (attr node 'firstgid string->number))
286 (source (scope (attr node 'source)))
287 (tree (call-with-input-file source xml->sxml)))
288 (parse-internal-tileset (car ((sxpath '(tileset)) tree)) first-gid)))
289 (define (parse-tileset node)
290 (if (attr node 'source)
291 (parse-external-tileset node)
292 (parse-internal-tileset node (first-gid node))))
293 (define (tile-gid->map-tile raw-gid tilesets x y tile-width tile-height)
294 ;; The top 3 bits of the tile gid are flags for various types of
295 ;; flipping.
296 ;;
297 ;; TODO: Respect the flipping settings.
298 (let* ((flipped-horizontally? (> (logand raw-gid #x80000000) 0))
299 (flipped-vertically? (> (logand raw-gid #x40000000) 0))
300 (flipped-diagonally? (> (logand raw-gid #x20000000) 0))
301 ;; Remove the upper 3 bits to get the true tile id.
302 (gid (logand raw-gid #x1FFFFFFF))
303 (tileset (find (lambda (t)
304 (and (>= gid (tileset-first-gid t))
305 (< gid (+ (tileset-first-gid t)
306 (tileset-size t)))))
307 tilesets))
308 (tw (tileset-tile-width tileset))
309 (th (tileset-tile-height tileset)))
310 (%make-map-tile (vector-ref (tileset-tiles tileset)
311 (- gid (tileset-first-gid tileset)))
312 (make-rect (* x tw) (* y th) tw th))))
313 (define (tile-gids->map-tiles gids width height tilesets)
314 (let ((tiles (make-vector (* width height))))
315 (let y-loop ((y 0)
316 (rows (reverse gids))) ; invert y
317 (when (< y height)
318 (match rows
319 ((row . rest)
320 (let x-loop ((x 0)
321 (columns row))
322 (when (< x width)
323 (match columns
324 ((gid . rest)
325 (vector-set! tiles
326 (+ (* width y) x)
327 (if (zero? gid)
328 #f
329 (tile-gid->map-tile gid tilesets
330 x y width height)))
331 (x-loop (+ x 1) rest)))))
332 (y-loop (+ y 1) rest)))))
333 tiles))
334 (define (parse-csv lines width height tilesets)
335 (let ((gids (map (lambda (line)
336 (filter-map (lambda (s)
337 (and (not (string-null? s))
338 (string->number s)))
339 (string-split line #\,)))
340 (take (drop (string-split lines #\newline) 1) height))))
341 (tile-gids->map-tiles gids width height tilesets)))
342 (define (parse-layer-data node width height tilesets)
343 (let ((encoding (attr node 'encoding string->symbol))
344 (data (car ((sxpath '(*text*)) node))))
345 (match encoding
346 ('csv (parse-csv data width height tilesets))
347 (_ (error "unsupported tile layer encoding" encoding)))))
348 (define (parse-tile-layer node tilesets)
349 (let* ((name (attr node 'name))
350 (width (attr node 'width string->number))
351 (height (attr node 'height string->number))
352 (tiles (parse-layer-data ((sxpath '(data)) node)
353 width height tilesets))
354 (properties (map parse-property
355 ((sxpath '(properties property)) node))))
356 (%make-tile-layer name width height tiles properties)))
357 (define (parse-polygon node pixel-height)
358 (make-polygon
359 (list->vector
360 (map (lambda (s)
361 (match (string-split s #\,)
362 ((x y)
363 (vec2 (string->number x)
364 (- pixel-height (string->number y))))))
365 (string-split (attr node 'points) #\space)))))
366 (define (parse-object node pixel-height)
367 (let* ((id (attr node 'id string->number))
368 (name (attr node 'name))
369 (type (attr node 'type string->symbol))
370 (x (attr node 'x string->number))
371 (y (- pixel-height (attr node 'y string->number)))
372 (width (attr node 'width string->number))
373 (height (attr node 'height string->number))
374 (shape (if (and width height)
375 (make-rect x y width height)
376 (parse-polygon (car ((sxpath '(polygon)) node))
377 pixel-height)))
378 (properties (map parse-property
379 ((sxpath '(properties property)) node))))
380 (%make-map-object id name type shape properties)))
381 (define (parse-object-layer node pixel-height)
382 (let ((name (attr node 'name))
383 (objects (map (lambda (node)
384 (parse-object node pixel-height))
385 ((sxpath '(object)) node)))
386 (properties (map parse-property
387 ((sxpath '(properties property)) node))))
388 (%make-object-layer name objects properties)))
389 (let* ((tree (call-with-input-file file-name xml->sxml))
390 (m ((sxpath '(map)) tree))
391 (version (let ((version (attr m 'version)))
392 (unless (any (lambda (v) (string=? version v)) '("1.0" "1.1" "1.2"))
393 (error "unsupported tiled map format version" version))
394 version))
395 (orientation (attr m 'orientation string->symbol))
396 (width (attr m 'width string->number))
397 (height (attr m 'height string->number))
398 (tile-width (attr m 'tilewidth string->number))
399 (tile-height (attr m 'tileheight string->number))
400 (properties ((sxpath '(map properties property)) tree))
401 (tilesets (map parse-tileset ((sxpath '(map tileset)) tree)))
402 (layers ((node-or (sxpath '(map layer))
403 (sxpath '(map objectgroup)))
404 tree)))
405 (%make-tile-map orientation width height tile-width tile-height
406 tilesets
407 (list->vector
408 (map (lambda (node)
409 (match node
410 (('layer . _)
411 (parse-tile-layer node tilesets))
412 (('objectgroup . _)
413 (parse-object-layer node (* height tile-height)))))
414 layers))
415 (map parse-property properties)
416 (make-rect 0.0
417 0.0
418 (* width tile-width)
419 (* height tile-height)))))
420
421
422 (define (draw-tile-layer layer matrix x1 y1 x2 y2)
423 (let ((width (tile-layer-width layer))
424 (height (tile-layer-height layer)))
425 (let y-loop ((y y1))
426 (when (< y y2)
427 (let x-loop ((x x1))
428 (when (< x x2)
429 (let ((tile (vector-ref (tile-layer-tiles layer)
430 (+ (* y width) x))))
431 (when tile
432 (let ((tref (map-tile-ref tile)))
433 (sprite-batch-add* (tile-batch tref)
434 (map-tile-rect tile)
435 matrix
436 #:texture-region (tile-texture tref)))))
437 (x-loop (+ x 1))))
438 (y-loop (+ y 1))))))
439
440 (define* (draw-tile-map* tile-map matrix region #:key layers)
441 ;; Calculate the tiles that are visible so we don't waste time
442 ;; drawing unnecessary sprites.
443 (let* ((w (tile-map-width tile-map))
444 (h (tile-map-height tile-map))
445 (tw (tile-map-tile-width tile-map))
446 (th (tile-map-tile-height tile-map))
447 (rx (rect-x region))
448 (ry (rect-y region))
449 (rw (rect-width region))
450 (rh (rect-height region))
451 (x1 (max (inexact->exact (floor (/ rx tw))) 0))
452 (y1 (max (inexact->exact (floor (/ ry th))) 0))
453 (x2 (min (inexact->exact (ceiling (/ (+ rx rw) tw))) w))
454 (y2 (min (inexact->exact (ceiling (/ (+ ry rh) th))) h)))
455 (vector-for-each (lambda (i layer)
456 (when (and (tile-layer? layer)
457 (or (not layers)
458 (memv i layers)))
459 (for-each (lambda (tileset)
460 (sprite-batch-clear! (tileset-batch tileset)))
461 (tile-map-tilesets tile-map))
462 (draw-tile-layer layer matrix x1 y1 x2 y2)
463 (for-each (lambda (tileset)
464 (draw-sprite-batch (tileset-batch tileset)))
465 (tile-map-tilesets tile-map))))
466 (tile-map-layers tile-map))))
467
468 (define %null-vec2 (vec2 0.0 0.0))
469 (define %default-scale (vec2 1.0 1.0))
470 (define %matrix (make-null-matrix4))
471 (define %region (make-rect 0.0 0.0 0.0 0.0))
472
473 ;; Make a default region that is as big as the viewport.
474 (define (default-region tile-map position)
475 (let ((vp (current-viewport)))
476 (set-rect-x! %region (- (vec2-x position)))
477 (set-rect-y! %region (- (vec2-y position)))
478 (set-rect-width! %region (viewport-width vp))
479 (set-rect-height! %region (viewport-height vp))
480 %region))
481
482 (define* (draw-tile-map tile-map
483 #:key
484 layers
485 (position %null-vec2)
486 (region (default-region tile-map position))
487 (origin %null-vec2)
488 (scale %default-scale)
489 (rotation 0.0))
490 "Draw TILE-MAP. By default, all layers are drawn. The LAYERS
491 argument may be used to specify a list of layers to draw, instead."
492 (matrix4-2d-transform! %matrix
493 #:origin origin
494 #:position position
495 #:rotation rotation
496 #:scale scale)
497 (draw-tile-map* tile-map %matrix region #:layers layers))