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 @@ + + + + + +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, +24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24 + + + 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")))