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