summaryrefslogtreecommitdiff
path: root/compile-map.scm
diff options
context:
space:
mode:
Diffstat (limited to 'compile-map.scm')
-rw-r--r--compile-map.scm565
1 files changed, 565 insertions, 0 deletions
diff --git a/compile-map.scm b/compile-map.scm
new file mode 100644
index 0000000..11b8d9e
--- /dev/null
+++ b/compile-map.scm
@@ -0,0 +1,565 @@
+;;; Adapted from the Chickadee Game Toolkit
+;;; Copyright © 2018, 2020, 2021, 2023 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(use-modules (ice-9 match)
+ (ice-9 pretty-print)
+ ((rnrs base) #:select (mod))
+ (rnrs bytevectors)
+ (srfi srfi-1)
+ (srfi srfi-11)
+ (srfi srfi-9)
+ (srfi srfi-43)
+ (sxml simple)
+ (sxml xpath))
+
+(define-record-type <vec2>
+ (make-vec2 x y)
+ vec2?
+ (x vec2-x)
+ (y vec2-y))
+
+(define-record-type <rect>
+ (make-rect x y width height)
+ rect?
+ (x rect-x)
+ (y rect-y)
+ (width rect-width)
+ (height rect-height))
+
+(define-record-type <color>
+ (make-color r g b a)
+ color?
+ (r color-r)
+ (g color-g)
+ (b color-b)
+ (a color-a))
+
+(define-record-type <image>
+ (make-image src width height trans)
+ image?
+ (src image-src)
+ (width image-width)
+ (height image-height)
+ (trans image-trans))
+
+
+;;;
+;;; Tileset
+;;;
+
+(define-record-type <animation-frame>
+ (make-animation-frame id duration)
+ animation-frame?
+ (id animation-frame-id)
+ (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)
+ (make-animation-frame (- id first-gid) 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 image animation properties)
+ tile?
+ (id tile-id)
+ (image tile-image)
+ (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
+ margin spacing rows columns tiles properties)
+ tileset?
+ (name tileset-name)
+ (first-gid tileset-first-gid)
+ (tile-width tileset-tile-width)
+ (tile-height tileset-tile-height)
+ (margin tileset-margin)
+ (spacing tileset-spacing)
+ (rows tileset-rows)
+ (columns tileset-columns)
+ (tiles tileset-tiles)
+ (properties tileset-properties))
+
+(define (tileset-dimensions image tile-width tile-height margin spacing)
+ (values (inexact->exact
+ (ceiling (/ (- (image-width image) margin)
+ (+ tile-width spacing))))
+ (inexact->exact
+ (ceiling (/ (- (image-height image) margin)
+ (+ tile-height spacing))))))
+
+(define* (make-tileset image tile-width tile-height #:key
+ (first-gid 1) (margin 0) (spacing 0)
+ (name "anonymous") (properties '())
+ (custom-tiles '()))
+ (let-values (((columns rows)
+ (tileset-dimensions image tile-width tile-height margin spacing)))
+ (let* ((tiles (make-vector (* columns rows))))
+ (do ((i 0 (+ i 1)))
+ ((= 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 i
+ (and animation
+ (make-animation image first-gid animation))
+ (or properties '()))))
+ (vector-set! tiles i tile)))
+ (%make-tileset name first-gid tile-width tile-height margin spacing
+ rows columns tiles properties))))
+
+(define (tileset-size tileset)
+ (vector-length (tileset-tiles 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))
+
+
+;;;
+;;; Tile Layer
+;;;
+
+(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 <tile-layer>
+ (%make-tile-layer name width height properties tiles)
+ tile-layer?
+ (name tile-layer-name)
+ (width tile-layer-width)
+ (height tile-layer-height)
+ (properties tile-layer-properties)
+ (tiles tile-layer-tiles))
+
+(define* (make-tile-layer width height tile-width tile-height #:key
+ (name "anonymous")
+ (properties '()))
+ (%make-tile-layer name width height properties (make-vector (* width height))))
+
+(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 (tile-layer-ref layer x y)
+ (vector-ref (tile-layer-tiles layer) (+ (* y (tile-layer-width layer)) x)))
+
+(define (tile-layer-set! layer x y tile)
+ (vector-set! (tile-layer-tiles layer) (+ (* y (tile-layer-width layer)) x) tile))
+
+
+;;;
+;;; 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)
+ "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))
+ (width (string->number (attr node 'width)))
+ (height (string->number (attr node 'height)))
+ (trans (attr node 'trans)))
+ (make-image (scope source) width height 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))
+ (image (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 image tile-width tile-height
+ #:margin margin
+ #:spacing spacing
+ #:name name
+ #:first-gid first-gid
+ #:properties properties
+ #:custom-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 gids))
+ (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)))
+ (do ((y 0 (+ y 1)))
+ ((= y height))
+ (do ((x 0 (+ x 1)))
+ ((= x width))
+ (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)
+ (make-vec2 (string->number x) (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 (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 tile-map (load-tile-map "level.tmx"))
+
+(define (compile-tile-layer layer)
+ `(vector
+ ,@(map (lambda (y)
+ (bytevector-copy
+ (list->f64vector
+ (concatenate
+ (filter-map (lambda (x)
+ (let ((tile (tile-layer-ref layer x y)))
+ (and tile
+ (list (* (exact->inexact x) 16.0)
+ (* (exact->inexact
+ (- (tile-id (map-tile-ref tile)) 1))
+ 16.0)))))
+ (iota (tile-layer-width layer)))))))
+ (iota (tile-layer-height layer)))))
+
+(define (compile-collision-layer layer)
+ (u8-list->bytevector
+ (append-map (lambda (y)
+ (map (lambda (x)
+ (if (tile-layer-ref layer x y) 1 0))
+ (iota (tile-layer-width layer))))
+ (iota (tile-layer-height layer)))))
+
+(define (compile-object-layer layer)
+ (let ((table (make-hash-table))
+ (tw (tile-map-tile-width tile-map))
+ (th (tile-map-tile-height tile-map)))
+ (for-each (lambda (obj)
+ (let* ((type (map-object-type obj))
+ (r (map-object-shape obj))
+ (x (/ (rect-x r) tw))
+ (y (/ (rect-y r) th)))
+ ;; (format (current-error-port) "obj: ~a ~a ~a ~a\n" (rect-x r) (rect-y r) x y)
+ (hashv-set! table y
+ (cons `(make-level-object ,x (quote ,type))
+ (hashv-ref table y '())))))
+ (object-layer-objects layer))
+ `(vector
+ ,@(map (lambda (y)
+ `(list ,@(hashv-ref table y '())))
+ (iota (tile-map-height tile-map))))))
+
+(pretty-print
+ `(make-level
+ ,(tile-map-height tile-map)
+ ,(compile-tile-layer (tile-map-layer-ref tile-map "foreground"))
+ ,(compile-tile-layer (tile-map-layer-ref tile-map "background"))
+ ,(compile-collision-layer (tile-map-layer-ref tile-map "collision"))
+ ,(compile-object-layer (tile-map-layer-ref tile-map "objects"))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-07-03 13:16:07 +0000