From 3a1afc62724f1631f23b5aa044856f7d09db14eb Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 25 Oct 2023 08:20:48 -0400
Subject: Lots of changes!

* Update reflect library
* Text alginment
* Tiled map compilation!
---
 compile-map.scm | 565 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 565 insertions(+)
 create mode 100644 compile-map.scm

(limited to 'compile-map.scm')

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"))))
-- 
cgit v1.2.3