diff --git a/.gitignore b/.gitignore
index 907c4d7..74967b6 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1 +1,2 @@
/game.wasm
+/modules/game/levels/*.scm
diff --git a/Makefile b/Makefile
index 31f1b94..d604e0d 100644
--- a/Makefile
+++ b/Makefile
@@ -22,9 +22,16 @@ modules = \
modules/srfi/srfi-9.scm \
modules/srfi/srfi-11.scm
-game.wasm: game.scm $(modules)
+levels = \
+ modules/game/levels/level-1.scm
+
+game.wasm: game.scm $(modules) $(levels)
guild compile-wasm -L modules -o $@ $<
+$(levels): %.scm: %.tmx scripts/compile-map.scm
+ mkdir -p modules/game/levels
+ guile scripts/compile-map.scm $< > $@
+
serve: game.wasm
guile -c '((@ (hoot web-server) serve))'
diff --git a/assets/sounds/brick.wav b/assets/sounds/brick.wav
deleted file mode 100644
index 9212400..0000000
Binary files a/assets/sounds/brick.wav and /dev/null differ
diff --git a/assets/sounds/no.wav b/assets/sounds/no.wav
new file mode 100644
index 0000000..bf00449
Binary files /dev/null and b/assets/sounds/no.wav differ
diff --git a/assets/sounds/paddle.wav b/assets/sounds/paddle.wav
deleted file mode 100644
index 94fb4f2..0000000
Binary files a/assets/sounds/paddle.wav and /dev/null differ
diff --git a/assets/sounds/push.wav b/assets/sounds/push.wav
new file mode 100644
index 0000000..09b370d
Binary files /dev/null and b/assets/sounds/push.wav differ
diff --git a/assets/sounds/undo.wav b/assets/sounds/undo.wav
new file mode 100644
index 0000000..aafd7a0
Binary files /dev/null and b/assets/sounds/undo.wav differ
diff --git a/game.scm b/game.scm
index 8389e61..7b5672f 100644
--- a/game.scm
+++ b/game.scm
@@ -26,8 +26,10 @@
(dom media)
(dom window)
(game actors)
+ (game levels level-1)
(game tileset)
(goblins core)
+ (hoot bytevectors)
(hoot ffi)
(hoot hashtables)
(ice-9 match)
@@ -52,7 +54,14 @@
320 240
(inexact->exact tile-width)
(inexact->exact tile-height)))
-(define audio:bump (make-audio "assets/sounds/bump.wav"))
+(define* (load-sound-effect name #:key (volume 0.5))
+ (let ((audio (make-audio (string-append "assets/sounds/" name ".wav"))))
+ (set-media-volume! audio volume)
+ audio))
+(define audio:bump (load-sound-effect "bump"))
+(define audio:push (load-sound-effect "push"))
+(define audio:undo (load-sound-effect "undo"))
+(define audio:no (load-sound-effect "no"))
;; Game state
(define *actormap* (make-whactormap))
@@ -64,6 +73,8 @@
(define *level* #f)
;; Latest representation of all actors in level
(define *grid* #f)
+;; Background tile layer.
+(define *background* #f)
(define *snapshots* '())
(define (clear-snapshots!)
@@ -72,10 +83,11 @@
(set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))
(define (rollback-snapshot!)
(match *snapshots*
- (() #f)
+ (() (media-play audio:no))
((snapshot . older-snapshots)
(set! *actormap* snapshot)
- (set! *snapshots* older-snapshots))))
+ (set! *snapshots* older-snapshots)
+ (media-play audio:undo))))
(define (update-grid!)
(set! *grid* ($ *level* 'describe)))
@@ -84,7 +96,10 @@
(set! *actormap* (make-whactormap))
(clear-snapshots!)
(with-goblins
- (set! *level* (spawn ^level level-width level-height))
+ (call-with-values load-level-1
+ (lambda (background level)
+ (set! *background* background)
+ (set! *level* level)))
(update-grid!)))
;; Update loop
@@ -92,7 +107,8 @@
(save-snapshot!)
(with-goblins
(match ($ *level* 'move-player dir)
- (#f (media-play audio:bump))
+ ('bump (media-play audio:bump))
+ ('push (media-play audio:push))
(_ #f))
(update-grid!)))
@@ -154,7 +170,19 @@
(('block type) (draw-block type x y))
(('clock-emitter) (draw-clock-emitter x y))))))
+(define (draw-background)
+ (let* ((bv *background*)
+ (len (bytevector-length bv)))
+ (let lp ((i 0))
+ (when (< i len)
+ (let ((x (bytevector-ieee-single-native-ref bv i))
+ (y (bytevector-ieee-single-native-ref bv (+ i 4)))
+ (idx (bytevector-s16-native-ref bv (+ i 8))))
+ (draw-tile context tileset idx x y)
+ (lp (+ i 10)))))))
+
(define (draw-level)
+ (draw-background)
(let ((grid *grid*))
(let y-loop ((y 0))
(when (< y level-height)
@@ -166,8 +194,6 @@
(define (draw prev-time)
(clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
- (set-fill-color! context "#cbdbfc")
- (fill-rect context 0.0 0.0 *canvas-width* *canvas-height*)
(set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
(set-scale! context *canvas-scale* *canvas-scale*)
(draw-level)
diff --git a/modules/game/actors.scm b/modules/game/actors.scm
index 490dd05..4a7b3d9 100644
--- a/modules/game/actors.scm
+++ b/modules/game/actors.scm
@@ -29,7 +29,7 @@
(('set-wire-state type)
(bcom (^wall bcom type)))
(('describe) `(wall ,type))
- (('collide) 'stop)))
+ (('collide) 'bump)))
(define (^block bcom type)
(match-lambda*
@@ -42,7 +42,7 @@
(('set-wire-state type)
(bcom (^block bcom type)))
(('describe) `(block ,type))
- (('collide) 'displace)))
+ (('collide) 'push)))
(define (^clock-emitter bcom interval)
(define timer (spawn ^cell 0))
@@ -59,7 +59,7 @@
'copper))))
(('set-wire-state type) #f)
(('describe) '(clock-emitter))
- (('collide) 'stop)))
+ (('collide) 'bump)))
(define (^player bcom)
(match-lambda*
@@ -106,9 +106,9 @@
($ player-coords (vector x y)))
(occupant
(match ($ occupant 'collide)
- ('stop #f)
+ ('bump 'bump)
('goal (pk 'GOAL))
- ('displace
+ ('push
(let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy)))))
(match ($ next-cell)
(#f
@@ -116,7 +116,7 @@
($ cell player)
($ old-cell #f)
($ player-coords (vector x y))
- 'displace)
+ 'push)
(_ #f)))))))))))
(define (warp-player x y)
($ (grid-ref grid x y) player)
@@ -182,7 +182,7 @@
($ (grid-ref grid 4 3) (spawn ^clock-emitter 3))
($ (grid-ref grid 5 3) (spawn ^wall 'copper))
- ($ (grid-ref grid 6 4) (spawn ^block 'copper))
+ ($ (grid-ref grid 6 5) (spawn ^block 'copper))
($ (grid-ref grid 7 3) (spawn ^wall 'copper))
($ (grid-ref grid 8 3) (spawn ^wall 'copper))
($ (grid-ref grid 9 3) (spawn ^wall 'copper))
diff --git a/modules/game/levels/level-1.tmx b/modules/game/levels/level-1.tmx
new file mode 100644
index 0000000..3564841
--- /dev/null
+++ b/modules/game/levels/level-1.tmx
@@ -0,0 +1,23 @@
+
+
diff --git a/modules/game/levels/tiles.tsx b/modules/game/levels/tiles.tsx
new file mode 100644
index 0000000..c0e26a3
--- /dev/null
+++ b/modules/game/levels/tiles.tsx
@@ -0,0 +1,4 @@
+
+
+
+
diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm
new file mode 100644
index 0000000..2aee8be
--- /dev/null
+++ b/scripts/compile-map.scm
@@ -0,0 +1,588 @@
+;;; Adapted from the Chickadee Game Toolkit
+;;; Copyright © 2018, 2020, 2021, 2023 David Thompson
+;;;
+;;; 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
+ (make-vec2 x y)
+ vec2?
+ (x vec2-x)
+ (y vec2-y))
+
+(define-record-type
+ (make-rect x y width height)
+ rect?
+ (x rect-x)
+ (y rect-y)
+ (width rect-width)
+ (height rect-height))
+
+(define-record-type
+ (make-color r g b a)
+ color?
+ (r color-r)
+ (g color-g)
+ (b color-b)
+ (a color-a))
+
+(define-record-type
+ (make-image src width height trans)
+ image?
+ (src image-src)
+ (width image-width)
+ (height image-height)
+ (trans image-trans))
+
+
+;;;
+;;; Tileset
+;;;
+
+(define-record-type
+ (make-animation-frame id duration)
+ animation-frame?
+ (id animation-frame-id)
+ (duration animation-frame-duration))
+
+(define-record-type
+ (%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
+ (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
+ (%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
+ (%make-object-layer name objects properties)
+ object-layer?
+ (name object-layer-name)
+ (objects object-layer-objects)
+ (properties object-layer-properties))
+
+(define-record-type
+ (make-polygon points)
+ polygon?
+ (points polygon-points))
+
+(define-record-type
+ (%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
+ (%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
+ (%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
+ (%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 tile-id ;; (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 (attr node 'id string->number)
+ ;; (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)))
+ (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 (- gid first-gid) ;; (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 (bytevector-concat bvs)
+ (let* ((size (fold (lambda (bv sum)
+ (+ sum (bytevector-length bv)))
+ 0 bvs))
+ (new-bv (make-bytevector size)))
+ (let loop ((bvs bvs) (offset 0))
+ (match bvs
+ (() new-bv)
+ ((bv . rest)
+ (let ((len (bytevector-length bv)))
+ (bytevector-copy! bv 0 new-bv offset len)
+ (loop rest (+ offset len))))))))
+
+(define (compile-tile-layer tile-map layer-name)
+ (let ((tw (tile-map-tile-width tile-map))
+ (th (tile-map-tile-height tile-map))
+ (layer (tile-map-layer-ref tile-map layer-name)))
+ (bytevector-concat
+ (append-map (lambda (y)
+ (filter-map (lambda (x)
+ (let ((tile (tile-layer-ref layer x y)))
+ (and tile
+ (let ((bv (make-bytevector 10)))
+ (bytevector-ieee-single-native-set! bv 0 (* x tw))
+ (bytevector-ieee-single-native-set! bv 4 (* y th))
+ (bytevector-s16-native-set! bv 8 (tile-id (map-tile-ref tile)))
+ bv))))
+ (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 tile-map 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))
+ (properties (map-object-properties 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)
+ (quote ,properties))
+ (hashv-ref table y '())))))
+ (object-layer-objects layer))
+ `(vector
+ ,@(map (lambda (y)
+ `(list ,@(hashv-ref table y '())))
+ (iota (tile-map-height tile-map))))))
+
+(define (basename-strip-extension file-name)
+ (match (string-split (basename file-name) #\.)
+ ((base . _) base)))
+
+(match (command-line)
+ ((_ file-name)
+ (let* ((name (basename-strip-extension file-name))
+ (module-name `(game levels ,(string->symbol name)))
+ (proc-name (string->symbol (string-append "load-" name)))
+ (tile-map (load-tile-map file-name)))
+ (for-each pretty-print
+ `((define-module ,module-name
+ #:use-module (game actors)
+ #:use-module (goblins core)
+ #:use-module (math vector)
+ #:export (,proc-name))
+ (define (,proc-name)
+ (values ,(compile-tile-layer tile-map "background")
+ (spawn ^level
+ ,(tile-map-width tile-map)
+ ,(tile-map-height tile-map))))))))
+ (_ (error "file name expected")))