path: root/chickadee/graphics/tile-map.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2018, 2020, 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Chickadee is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Chickadee is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Tile map renderer and Tiled map format loader.
;;
;;; Code:

(define-module (chickadee graphics tile-map)
  #:use-module (chickadee)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee graphics blend)
  #:use-module (chickadee graphics buffer)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics shader)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee graphics viewport)
  #:use-module (chickadee utils)
  #:use-module (ice-9 match)
  #:use-module ((rnrs base) #:select (mod))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-43)
  #:use-module (sxml simple)
  #:use-module (sxml xpath)
  #:export (animation-frame?
            animation-frame-tile
            animation-frame-duration

            animation?
            animation-frames
            animation-duration

            tile?
            tile-id
            tile-texture
            tile-animation
            tile-properties

            make-tileset
            tileset?
            tileset-name
            tileset-first-gid
            tileset-size
            tileset-tile-width
            tileset-tile-height
            tileset-rows
            tileset-columns
            tileset-properties

            make-map-tile
            map-tile?
            map-tile-ref
            map-tile-flipped-horizontally?
            map-tile-flipped-vertically?
            map-tile-flipped-diagonally?

            make-tile-layer
            tile-layer?
            tile-layer-name
            tile-layer-width
            tile-layer-height
            tile-layer-chunk-size
            tile-layer-properties
            tile-layer-ref
            tile-layer-set!

            object-layer?
            object-layer-name
            object-layer-objects
            object-layer-properties

            polygon?
            polygon-points

            map-object?
            map-object-id
            map-object-name
            map-object-type
            map-object-shape
            map-object-properties

            make-tile-map
            tile-map?
            tile-map-orientation
            tile-map-width
            tile-map-height
            tile-map-tile-width
            tile-map-tile-height
            tile-map-tilesets
            tile-map-layers
            tile-map-properties
            tile-map-rect
            tile-map-layer-ref
            point->tile
            load-tile-map
            draw-tile-map
            draw-tile-map*))


;;;
;;; Tileset
;;;

(define-record-type <animation-frame>
  (make-animation-frame texture duration)
  animation-frame?
  (texture animation-frame-texture)
  (duration animation-frame-duration))

(define-record-type <animation>
  (%make-animation frames duration)
  animation?
  (frames animation-frames)
  (duration animation-duration))

(define (make-animation atlas first-gid frame-spec)
  (let ((frames (map (match-lambda
                       ((id duration)
                        (let ((texture (texture-atlas-ref atlas
                                                          (- id first-gid))))
                          (make-animation-frame texture duration))))
                     frame-spec)))
    (%make-animation (list->vector frames)
                     (fold (lambda (frame memo)
                             (+ (animation-frame-duration frame) memo))
                           0 frames))))

(define (animation-frame-for-time animation time)
  (let* ((time (mod time (animation-duration animation)))
         (frames (animation-frames animation)))
    (let loop ((i 0)
               (t 0))
      (let* ((frame (vector-ref frames i))
             (d (animation-frame-duration frame)))
        (if (< time (+ t d))
            frame
            (loop (+ i 1) (+ t d)))))))

(define-record-type <tile>
  (make-tile id texture animation properties)
  tile?
  (id tile-id)
  (texture tile-texture)
  (animation tile-animation)
  (properties tile-properties))

(define (animated-tile? tile)
  (animation? (tile-animation tile)))

(define (tile-frame-for-time tile time)
  (let ((animation (tile-animation tile)))
    (and animation (animation-frame-for-time animation time))))

(define-record-type <tileset>
  (%make-tileset name first-gid tile-width tile-height
                 rows columns atlas tiles properties)
  tileset?
  (name tileset-name)
  (first-gid tileset-first-gid)
  (tile-width tileset-tile-width)
  (tile-height tileset-tile-height)
  (rows tileset-rows)
  (columns tileset-columns)
  (atlas tileset-atlas)
  (tiles tileset-tiles)
  (properties tileset-properties))

(define* (make-tileset texture tile-width tile-height #:key
                       (first-gid 1) (margin 0) (spacing 0)
                       (name "anonymous") (properties '())
                       (custom-tiles '()))
  (call-with-values (lambda ()
                      (texture-tileset-dimensions texture tile-width tile-height
                                                  #:margin margin
                                                  #:spacing spacing))
    (lambda (columns rows)
      (let* ((atlas (split-texture texture tile-width tile-height
                                   #:margin margin
                                   #:spacing spacing))
             (tiles (make-vector (texture-atlas-size atlas))))
        (for-range ((i (vector-length tiles)))
          (let* ((id (+ first-gid i))
                 (custom (or (assv-ref custom-tiles id) '()))
                 (animation (assq-ref custom 'animation))
                 (properties (assq-ref custom 'properties))
                 (tile (make-tile id (texture-atlas-ref atlas i)
                                  (and animation (make-animation atlas first-gid animation))
                                  (or properties '()))))
            (vector-set! tiles i tile)))
        (%make-tileset name first-gid tile-width tile-height rows columns
                       atlas tiles properties)))))

(define (tileset-size tileset)
  (texture-atlas-size (tileset-atlas tileset)))

(define (tileset-ref tileset i)
  (vector-ref (tileset-tiles tileset) (- i (tileset-first-gid tileset))))


;;;
;;; Object Layer
;;;

(define-record-type <object-layer>
  (%make-object-layer name objects properties)
  object-layer?
  (name object-layer-name)
  (objects object-layer-objects)
  (properties object-layer-properties))

(define-record-type <polygon>
  (make-polygon points)
  polygon?
  (points polygon-points))

(define-record-type <map-object>
  (%make-map-object id name type shape properties)
  map-object?
  (id map-object-id)
  (name map-object-name)
  (type map-object-type)
  (shape map-object-shape)
  (properties map-object-properties))


;;;
;;; Chunk
;;;

(define-record-type <map-tile>
  (%make-map-tile tile flipped-horizontally? flipped-vertically?
                  flipped-diagonally?)
  map-tile?
  (tile map-tile-ref)
  (flipped-horizontally? map-tile-flipped-horizontally?)
  (flipped-vertically? map-tile-flipped-vertically?)
  (flipped-diagonally? map-tile-flipped-diagonally?))

(define* (make-map-tile tile #:key flipped-horizontally?
                        flipped-vertically? flipped-diagonally?)
  (%make-map-tile tile flipped-horizontally? flipped-vertically?
                  flipped-diagonally?))

(define-record-type <chunk>
  (%make-chunk size tile-x tile-y tile-width tile-height anim-tiles
               anim-frames tiles rebuild-geometry? geometry)
  chunk?
  (size chunk-size)
  (tile-x chunk-tile-x)
  (tile-y chunk-tile-y)
  (tile-width chunk-tile-width)
  (tile-height chunk-tile-height)
  (anim-tiles chunk-anim-tiles)
  (anim-frames chunk-anim-frames)
  (tiles chunk-tiles)
  (rebuild-geometry? chunk-rebuild-geometry? set-chunk-rebuild-geometry!)
  (geometry chunk-geometry))

(define %default-chunk-size 30)

(define-geometry-type <chunk-vertex>
  chunk-vertex-ref
  chunk-vertex-set!
  chunk-vertex-append!
  (position vec2)
  (texture vec2))

(define (make-chunk size tile-x tile-y tile-width tile-height)
  (let ((tiles (make-vector size)))
    (for-range ((y size))
      (let ((row (make-vector size)))
        (for-range ((x size))
          (vector-set! row x #f))
        (vector-set! tiles y row)))
    (%make-chunk size tile-x tile-y tile-width tile-height
                 (make-hash-table) (make-hash-table) tiles #t
                 (make-hash-table))))

(define (chunk-anim-decrement chunk tile)
  (let* ((t (chunk-anim-tiles chunk))
         (n (hashq-ref t tile 0)))
    (cond
     ((= n 0)
      #f)
     ((= n 1)
      (hashq-remove! t tile)
      (hashq-remove! (chunk-anim-frames chunk) tile))
     (else
      (hashq-set! t tile (- n 1))))))

(define (chunk-anim-increment chunk tile)
  (let ((t (chunk-anim-tiles chunk)))
    (hashq-set! t tile (+ (or (hashq-ref t tile) 0) 1))))

(define (chunk-bounds-check chunk x y)
  (let ((n (chunk-size chunk)))
    (unless (and (>= x 0) (>= y 0) (< x n) (< y n))
      (error "chunk index out of bounds" x y))))

(define (chunk-ref chunk x y)
  (chunk-bounds-check chunk x y)
  (vector-ref (vector-ref (chunk-tiles chunk) y) x))

(define (chunk-ensure-geometry chunk texture)
  (let ((chunk-size (chunk-size chunk))
        (geometry-table (chunk-geometry chunk)))
    (unless (hashq-ref geometry-table texture)
      (let ((g (make-geometry <chunk-vertex>
                              (* chunk-size chunk-size 4)
                              #:index-capacity
                              (* chunk-size chunk-size 6))))
        (hashq-set! geometry-table texture g)))))

(define (chunk-set! chunk x y tile)
  (let ((tiles (chunk-tiles chunk)))
    (chunk-bounds-check chunk x y)
    (let ((existing-tile (chunk-ref chunk x y)))
      (when (and existing-tile (animated-tile? (map-tile-ref existing-tile)))
        (chunk-anim-decrement chunk (map-tile-ref existing-tile))))
    (vector-set! (vector-ref tiles y) x tile)
    (when tile
      (let* ((tile* (map-tile-ref tile))
             (texture (texture-parent (tile-texture tile*))))
        (when (animated-tile? tile*)
          (chunk-anim-increment chunk tile*))
        (chunk-ensure-geometry chunk texture)))
    (set-chunk-rebuild-geometry! chunk #t)))

(define (chunk-rebuild-geometry! chunk)
  (let* ((anim-frames (chunk-anim-frames chunk))
         (t (chunk-geometry chunk))
         (n (chunk-size chunk))
         (tw (exact->inexact (chunk-tile-width chunk)))
         (th (exact->inexact (chunk-tile-height chunk)))
         (x0 (* (chunk-tile-x chunk) tw))
         (y0 (* (chunk-tile-y chunk) th)))
    (hash-for-each (lambda (texture geometry)
                     (geometry-begin! geometry))
                   t)
    (for-range ((x n) (y n))
      (let ((tile (chunk-ref chunk x y)))
        (when tile
          (let* ((tile* (map-tile-ref tile))
                 (texture (if (animated-tile? tile*)
                              (animation-frame-texture
                               (hashq-ref anim-frames tile*))
                              (tile-texture tile*)))
                 (geometry (hashq-ref t (texture-parent texture)))
                 (vertex-offset (geometry-vertex-count geometry <chunk-vertex>))
                 (x1 (+ x0 (* x tw)))
                 (y1 (+ y0 (* y th)))
                 (x2 (+ x1 tw))
                 (y2 (+ y1 th))
                 (texcoords (texture-gl-tex-rect texture))
                 (s1 (rect-left texcoords))
                 (t1 (rect-bottom texcoords))
                 (s2 (rect-right texcoords))
                 (t2 (rect-top texcoords))
                 (flip-h? (map-tile-flipped-horizontally? tile))
                 (flip-v? (map-tile-flipped-vertically? tile))
                 (flip-d? (map-tile-flipped-diagonally? tile))
                 (as (cond
                      ((and flip-d? flip-h?) s2)
                      ((and flip-d? flip-v?) s1)
                      (flip-h? s2)
                      (else s1)))
                 (at (cond
                      ((and flip-d? flip-h?) t1)
                      ((and flip-d? flip-v?) t2)
                      (flip-v? t2)
                      (else t1)))
                 (bs (cond
                      ((and flip-d? flip-h?) s2)
                      ((and flip-d? flip-v?) s1)
                      (flip-h? s1)
                      (else s2)))
                 (bt (cond
                      ((and flip-d? flip-h?) t2)
                      ((and flip-d? flip-v?) t1)
                      (flip-v? t2)
                      (else t1)))
                 (cs (cond
                      ((and flip-d? flip-h?) s1)
                      ((and flip-d? flip-v?) s2)
                      (flip-h? s1)
                      (else s2)))
                 (ct (cond
                      ((and flip-d? flip-h?) t2)
                      ((and flip-d? flip-v?) t1)
                      (flip-v? t1)
                      (else t2)))
                 (ds (cond
                      ((and flip-d? flip-h?) s1)
                      ((and flip-d? flip-v?) s2)
                      (flip-h? s2)
                      (else s1)))
                 (dt (cond
                      ((and flip-d? flip-h?) t1)
                      ((and flip-d? flip-v?) t2)
                      (flip-v? t1)
                      (else t2))))
            (chunk-vertex-append! geometry
                                  (x1 y1 as at)
                                  (x2 y1 bs bt)
                                  (x2 y2 cs ct)
                                  (x1 y2 ds dt))
            (geometry-index-append! geometry
                                    vertex-offset
                                    (+ vertex-offset 3)
                                    (+ vertex-offset 2)
                                    vertex-offset
                                    (+ vertex-offset 2)
                                    (+ vertex-offset 1))))))
    (hash-for-each (lambda (texture geometry)
                     (geometry-end! geometry))
                   t)))

(define-graphics-variable tile-map-chunk-shader
  (strings->shader
   "
#ifdef GLSL330
layout (location = 0) in vec2 position;
layout (location = 1) in vec2 tex;
#elif defined(GLSL130)
in vec2 position;
in vec2 tex;
#elif defined(GLSL120)
attribute vec2 position;
attribute vec2 tex;
#endif
#ifdef GLSL120
varying vec2 fragTex;
#else
out vec2 fragTex;
#endif
uniform mat4 mvp;

void main(void) {
    fragTex = tex;
    gl_Position = mvp * vec4(position.xy, 0.0, 1.0);
}
"
   "
#ifdef GLSL120
varying vec2 fragTex;
#else
in vec2 fragTex;
#endif
#ifdef GLSL330
out vec4 fragColor;
#endif
uniform sampler2D colorTexture;
uniform vec4 tint;

void main (void) {
#ifdef GLSL330
    fragColor = texture(colorTexture, fragTex) * tint;
#else
    gl_FragColor = texture2D(colorTexture, fragTex) * tint;
#endif
}
"))

(define (draw-chunk-geometry texture geometry matrix tint)
  (with-graphics-state ((g:texture-0 texture))
    (shader-apply* (graphics-variable-ref tile-map-chunk-shader)
                   (geometry-vertex-array geometry)
                   0
                   (geometry-index-count geometry)
                   #:tint tint
                   #:mvp matrix)))

(define (draw-chunk chunk matrix blend-mode tint time)
  (let ((anim-tiles (chunk-anim-tiles chunk))
        (anim-frames (chunk-anim-frames chunk)))
    (hash-for-each (lambda (tile count)
                     (let ((old-frame (hashq-ref anim-frames tile))
                           (new-frame (tile-frame-for-time tile time)))
                       (unless (eq? old-frame new-frame)
                         (hashq-set! anim-frames tile new-frame)
                         (set-chunk-rebuild-geometry! chunk #t))))
                   anim-tiles))
  (when (chunk-rebuild-geometry? chunk)
    (chunk-rebuild-geometry! chunk)
    (set-chunk-rebuild-geometry! chunk #f))
  (with-graphics-state ((g:blend-mode blend-mode))
    (hash-for-each (lambda (texture geometry)
                     (draw-chunk-geometry texture geometry matrix tint))
                   (chunk-geometry chunk))))


;;;
;;; Tile Layer
;;;

(define-record-type <tile-layer>
  (%make-tile-layer name width height properties chunk-size chunks)
  tile-layer?
  (name tile-layer-name)
  (width tile-layer-width)
  (height tile-layer-height)
  (properties tile-layer-properties)
  (chunk-size tile-layer-chunk-size)
  (chunks tile-layer-chunks))

(define* (make-tile-layer width height tile-width tile-height #:key
                          (name "anonymous")
                          (properties '())
                          (chunk-size %default-chunk-size))
  (let* ((h (ceiling (/ height chunk-size)))
         (chunks (make-vector h)))
    (for-range ((y h))
      (let* ((w (ceiling (/ width chunk-size)))
             (row (make-vector w)))
        (for-range ((x w))
          (vector-set! row x (make-chunk chunk-size
                                         (* x chunk-size)
                                         (* y chunk-size)
                                         tile-width tile-height)))
        (vector-set! chunks y row)))
    (%make-tile-layer name width height properties chunk-size chunks)))

(define (tile-layer-bounds-check layer x y)
  (unless (and (>= x 0) (>= y 0)
               (< x (tile-layer-width layer))
               (< y (tile-layer-height layer)))
    (error "tile layer coordinates out of bounds" layer x y)))

(define (call-with-chunk layer x y proc)
  (tile-layer-bounds-check layer x y)
  (let ((n (tile-layer-chunk-size layer)))
    (proc (vector-ref (vector-ref (tile-layer-chunks layer)
                                  (floor (/ y n)))
                      (floor (/ x n)))
          (modulo x n)
          (modulo y n))))

(define (tile-layer-ref layer x y)
  (call-with-chunk layer x y
                   (lambda (chunk cx cy)
                     (chunk-ref chunk cx cy))))

(define (tile-layer-set! layer x y tile)
  (call-with-chunk layer x y
                   (lambda (chunk cx cy)
                     (chunk-set! chunk cx cy tile))))

(define (draw-tile-layer layer matrix x1 y1 x2 y2 blend-mode tint time)
  (let ((width (tile-layer-width layer))
        (height (tile-layer-height layer))
        (chunk-size (tile-layer-chunk-size layer))
        (chunks (tile-layer-chunks layer)))
    ;; Render only the visible chunks.
    (for-range ((x (ceiling (/ x2 chunk-size))
                   (floor (/ x1 chunk-size)))
                (y (ceiling (/ y2 chunk-size))
                   (floor (/ y1 chunk-size))))
      (draw-chunk (vector-ref (vector-ref chunks y) x)
                  matrix blend-mode tint time))))


;;;
;;; Tile Map
;;;

(define-record-type <tile-map>
  (%make-tile-map orientation width height tile-width tile-height
                  tilesets layers properties)
  tile-map?
  (orientation tile-map-orientation)
  (width tile-map-width)
  (height tile-map-height)
  (tile-width tile-map-tile-width)
  (tile-height tile-map-tile-height)
  (tilesets tile-map-tilesets)
  (layers tile-map-layers)
  (properties tile-map-properties))

(define* (make-tile-map width height tile-width tile-height #:key
                        (orientation 'orthogonal) (tilesets '())
                        (layers '()) (properties '()))
  "Make a tile map that is WIDTH x HEIGHT tiles in size and each tile
is TILE-WIDTH x TILE-HEIGHT pixels in size.  TILESETS is a list of
tilesets to be associated with the map.  LAYERS is a list of object
and/or tile layers, sorted from bottom to top.  PROPERTIES is an alist
of arbitrary custom data to associate with the map.  Currently, only
the default ORIENTATION value of 'orthogonal' is supported."
  (unless (eq? orientation 'orthogonal)
    (error "unsupport tile map orientation" orientation))
  (%make-tile-map orientation width height tile-width tile-height
                  tilesets (list->vector layers) properties))

(define (tile-map-layer-ref tile-map name)
  "Return the map layer named NAME."
  (define (layer-name layer)
    (if (tile-layer? layer)
        (tile-layer-name layer)
        (object-layer-name layer)))
  (let ((layers (tile-map-layers tile-map)))
    (let loop ((i 0))
      (cond
       ((= i (vector-length layers))
        #f)
       ((string=? name (layer-name (vector-ref layers i)))
        (vector-ref layers i))
       (else
        (loop (+ i 1)))))))

(define (point->tile tile-map x y)
  "Translate the pixel coordinates (X, Y) into tile coordinates."
  (values (inexact->exact (floor (/ x (tile-map-tile-width tile-map))))
          (inexact->exact (floor (/ y (tile-map-tile-height tile-map))))))

(define* (load-tile-map file-name #:key (chunk-size %default-chunk-size))
  "Load the Tiled TMX formatted map in FILE-NAME."
  (define map-directory
    (if (absolute-file-name? file-name)
        (dirname file-name)
        (string-append (getcwd) "/" (dirname file-name))))
  (define (scope file-name)
    (string-append map-directory "/" file-name))
  (define* (attr node name #:optional (parse identity))
    (let ((result ((sxpath `(@ ,name *text*)) node)))
      (if (null? result)
          #f
          (parse (car result)))))
  (define (parse-color-channel s start)
    (/ (string->number (substring s start (+ start 2)) 16) 255.0))
  (define (parse-property node)
    (let ((name (attr node 'name string->symbol))
          (type (or (attr node 'type string->symbol) 'string))
          (value (attr node 'value)))
      (cons name
            (match type
              ((or 'string 'file) value)
              ('bool (not (string=? value "false")))
              ((or 'int 'float) (string->number value))
              ('color
               (make-color (parse-color-channel value 3)
                           (parse-color-channel value 5)
                           (parse-color-channel value 7)
                           (parse-color-channel value 1)))
              (_ (error "unsupported property type" type))))))
  (define (parse-image node)
    (let ((source (attr node 'source))
          (trans (attr node 'trans)))
      (load-image (scope source)
                  #:transparent-color (and trans (string->color trans)))))
  (define (invert-tile-id id first-gid rows columns)
    (let ((id* (- id first-gid)))
      (+ (* (- rows (floor (/ id* columns)) 1)
            columns)
         (modulo id* columns)
         first-gid)))
  (define (parse-frame node first-gid rows columns)
    (let ((tile-id (attr node 'tileid string->number))
          (duration (attr node 'duration string->number)))
      (list (+ first-gid (invert-tile-id tile-id 0 rows columns))
            (/ duration 1000.0))))
  (define (parse-tiles nodes first-gid rows columns)
    (let ((frames (sxpath '(animation frame)))
          (properties (sxpath '(properties property))))
      (fold (lambda (node memo)
              (let ((id (+ first-gid
                           (invert-tile-id (attr node 'id string->number)
                                           0 rows columns))))
                (cons `(,id . ((animation . ,(map (lambda (f)
                                                    (parse-frame f first-gid
                                                                 rows columns))
                                                  (frames node)))
                               (properties . ,(map parse-property
                                                   (properties node)))))
                      memo)))
            '()
            nodes)))
  (define (first-gid node)
    (attr node 'firstgid string->number))
  (define (parse-tileset node first-gid)
    (let* ((name (attr node 'name))
           (tile-width (attr node 'tilewidth string->number))
           (tile-height (attr node 'tileheight string->number))
           (margin (or (attr node 'margin string->number) 0))
           (spacing (or (attr node 'spacing string->number) 0))
           (texture (parse-image ((sxpath '(image)) node)))
           (tiles (call-with-values
                      (lambda ()
                        (texture-tileset-dimensions texture
                                                    tile-width
                                                    tile-height
                                                    #:margin margin
                                                    #:spacing spacing))
                    (lambda (columns rows)
                      (parse-tiles ((sxpath '(tile)) node) first-gid rows columns))))
           (properties (map parse-property
                            ((sxpath '(properties property)) node))))
      (make-tileset texture tile-width tile-height
                    #:margin margin
                    #:spacing spacing
                    #:name name
                    #:first-gid first-gid
                    #:properties properties
                    #:custom-tiles tiles)))
  (define (parse-external-tileset node)
    (let* ((first-gid (attr node 'firstgid string->number))
           (source (scope (attr node 'source)))
           (tree (call-with-input-file source xml->sxml)))
      (parse-tileset (car ((sxpath '(tileset)) tree)) first-gid)))
  (define (parse-tileset* node)
    (if (attr node 'source)
        (parse-external-tileset node)
        (parse-tileset node (first-gid node))))
  (define (tile-gid->map-tile raw-gid tilesets x y tile-width tile-height)
    ;; The top 3 bits of the tile gid are flags for various types of
    ;; flipping.
    (let* ((flipped-horizontally? (> (logand raw-gid #x80000000) 0))
           (flipped-vertically? (> (logand raw-gid #x40000000) 0))
           (flipped-diagonally? (> (logand raw-gid #x20000000) 0))
           ;; Remove the upper 3 bits to get the true tile id.
           (gid (logand raw-gid #x1FFFFFFF))
           (tileset (find (lambda (t)
                            (and (>= gid (tileset-first-gid t))
                                 (< gid (+ (tileset-first-gid t)
                                           (tileset-size t)))))
                          tilesets))
           (tw (tileset-tile-width tileset))
           (th (tileset-tile-height tileset))
           (first-gid (tileset-first-gid tileset))
           (rows (tileset-rows tileset))
           (columns (tileset-columns tileset))
           (id (invert-tile-id gid first-gid rows columns)))
      (make-map-tile (tileset-ref tileset id)
                     #:flipped-horizontally? flipped-horizontally?
                     #:flipped-vertically? flipped-vertically?
                     #:flipped-diagonally? flipped-diagonally?)))
  (define (tile-gids->map-tiles gids width height tilesets)
    (let ((tiles (make-vector (* width height))))
      (let y-loop ((y 0)
                   (rows (reverse gids))) ; invert y
        (when (< y height)
          (match rows
            ((row . rest)
             (let x-loop ((x 0)
                          (columns row))
               (when (< x width)
                 (match columns
                   ((gid . rest)
                    (vector-set! tiles
                                 (+ (* width y) x)
                                 (if (zero? gid)
                                     #f
                                     (tile-gid->map-tile gid tilesets
                                                         x y width height)))
                    (x-loop (+ x 1) rest)))))
             (y-loop (+ y 1) rest)))))
      tiles))
  (define (parse-csv lines width height tilesets)
    (let ((gids (map (lambda (line)
                       (filter-map (lambda (s)
                                     (and (not (string-null? s))
                                          (string->number s)))
                                   (string-split line #\,)))
                     (take (drop (string-split lines #\newline) 1) height))))
      (tile-gids->map-tiles gids width height tilesets)))
  (define (parse-layer-data node width height tilesets)
    (let ((encoding (attr node 'encoding string->symbol))
          (data (car ((sxpath '(*text*)) node))))
      (match encoding
        ('csv (parse-csv data width height tilesets))
        (_ (error "unsupported tile layer encoding" encoding)))))
  (define (parse-tile-layer node tile-width tile-height tilesets)
    (let* ((name (attr node 'name))
           (width (attr node 'width string->number))
           (height (attr node 'height string->number))
           (tiles (parse-layer-data ((sxpath '(data)) node)
                                    width height tilesets))
           (properties (map parse-property
                            ((sxpath '(properties property)) node)))
           (layer (make-tile-layer width height tile-width tile-height
                                   #:name name
                                   #:properties properties
                                   #:chunk-size chunk-size)))
      (for-range ((x width)
                  (y height))
        (tile-layer-set! layer x y (vector-ref tiles (+ (* y width) x))))
      layer))
  (define (parse-polygon node pixel-height)
    (make-polygon
     (list->vector
      (map (lambda (s)
             (match (string-split s #\,)
               ((x y)
                (vec2 (string->number x)
                      (- pixel-height (string->number y))))))
           (string-split (attr node 'points) #\space)))))
  (define (parse-object node pixel-height)
    (let* ((id (attr node 'id string->number))
           (name (attr node 'name))
           (type (attr node 'type string->symbol))
           (x (attr node 'x string->number))
           (y (- pixel-height (attr node 'y string->number)))
           (width (attr node 'width string->number))
           (height (attr node 'height string->number))
           (shape (if (and width height)
                      (make-rect x y width height)
                      (parse-polygon (car ((sxpath '(polygon)) node))
                                     pixel-height)))
           (properties (map parse-property
                            ((sxpath '(properties property)) node))))
      (%make-map-object id name type shape properties)))
  (define (parse-object-layer node pixel-height)
    (let ((name (attr node 'name))
          (objects (map (lambda (node)
                          (parse-object node pixel-height))
                        ((sxpath '(object)) node)))
          (properties (map parse-property
                           ((sxpath '(properties property)) node))))
      (%make-object-layer name objects properties)))
  (let* ((tree (call-with-input-file file-name xml->sxml))
         (m ((sxpath '(map)) tree))
         (version (attr m 'version))
         (orientation (attr m 'orientation string->symbol))
         (width (attr m 'width string->number))
         (height (attr m 'height string->number))
         (tile-width (attr m 'tilewidth string->number))
         (tile-height (attr m 'tileheight string->number))
         (properties ((sxpath '(map properties property)) tree))
         (tilesets (map parse-tileset* ((sxpath '(map tileset)) tree)))
         (layers ((node-or (sxpath '(map layer))
                           (sxpath '(map objectgroup)))
                  tree)))
    (make-tile-map width height tile-width tile-height
                   #:orientation orientation
                   #:tilesets tilesets
                   #:layers (map (lambda (node)
                                   (match node
                                     (('layer . _)
                                      (parse-tile-layer node tile-width tile-height tilesets))
                                     (('objectgroup . _)
                                      (parse-object-layer node (* height tile-height)))))
                                 layers)
                    #:properties (map parse-property properties))))

(define* (draw-tile-map* tile-map matrix region #:key
                         layers (time (elapsed-time))
                         (blend-mode blend:alpha) (tint white))
  ;; Calculate the tiles that are visible so we don't waste time
  ;; drawing unnecessary sprites.
  (let* ((w (tile-map-width tile-map))
         (h (tile-map-height tile-map))
         (tw (tile-map-tile-width tile-map))
         (th (tile-map-tile-height tile-map))
         (rx (rect-x region))
         (ry (rect-y region))
         (rw (rect-width region))
         (rh (rect-height region))
         (x1 (max (inexact->exact (floor (/ rx tw))) 0))
         (y1 (max (inexact->exact (floor (/ ry th))) 0))
         (x2 (min (inexact->exact (ceiling (/ (+ rx rw) tw))) w))
         (y2 (min (inexact->exact (ceiling (/ (+ ry rh) th))) h)))
    (vector-for-each (lambda (i layer)
                       (when (and (tile-layer? layer)
                                  (or (not layers)
                                      (memv i layers)))
                         (draw-tile-layer layer matrix x1 y1 x2 y2 blend-mode tint time)))
                     (tile-map-layers tile-map))))

(define %null-vec2 (vec2 0.0 0.0))
(define %default-scale (vec2 1.0 1.0))
(define *matrix* (make-null-matrix4))
(define *position* (vec2 0.0 0.0))
(define *region* (make-rect 0.0 0.0 0.0 0.0))

(define* (draw-tile-map tile-map
                        #:key
                        layers
                        (camera %null-vec2)
                        (position %null-vec2)
                        (origin %null-vec2)
                        (scale %default-scale)
                        (rotation 0.0)
                        (blend-mode blend:alpha)
                        (tint white)
                        (time (elapsed-time)))
  "Draw TILE-MAP.  By default, all layers are drawn.  The LAYERS
argument may be used to specify a list of layers to draw, instead."
  ;; Make the region as big as the current viewport.
  (let ((vp (current-viewport)))
    (set-rect-x! *region* (vec2-x camera))
    (set-rect-y! *region* (vec2-y camera))
    (set-rect-width! *region* (viewport-width vp))
    (set-rect-height! *region* (viewport-height vp)))
  ;; Translation must be adjusted by inverse of camera.
  (vec2-copy! camera *position*)
  (vec2-mult! *position* -1.0)
  (vec2-add! *position* position)
  ;; XXX: Round position to nearest pixel to maybe avoid texture
  ;; artifacts caused by texels not aligning perfectly with the
  ;; viewport pixels.  Of course, if the projection matrix isn't pixel
  ;; perfect, or if the map is scaled, or if there is rotation, then
  ;; this issue can happen anyway.  Sigh... much to learn about how to
  ;; improve this.
  (set-vec2! *position*
             (round (vec2-x *position*))
             (round (vec2-y *position*)))
  (matrix4-2d-transform! *matrix*
                         #:origin origin
                         #:position *position*
                         #:rotation rotation
                         #:scale scale)
  (matrix4-mult! *matrix* *matrix* (current-projection))
  (draw-tile-map* tile-map *matrix* *region*
                  #:layers layers
                  #:blend-mode blend-mode
                  #:tint tint
                  #:time time))