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