diff --git a/Makefile b/Makefile index d604e0d..ff2f9fd 100644 --- a/Makefile +++ b/Makefile @@ -7,6 +7,7 @@ modules = \ modules/dom/media.scm \ modules/dom/window.scm \ modules/game/actors.scm \ + modules/game/level.scm \ modules/game/tileset.scm \ modules/goblins/abstract-types.scm \ modules/goblins/core.scm \ diff --git a/assets/sounds/exit.wav b/assets/sounds/exit.wav new file mode 100644 index 0000000..60f704d Binary files /dev/null and b/assets/sounds/exit.wav differ diff --git a/assets/sounds/pickup.wav b/assets/sounds/pickup.wav new file mode 100644 index 0000000..7810e7b Binary files /dev/null and b/assets/sounds/pickup.wav differ diff --git a/game.scm b/game.scm index 7710269..4e9b0de 100644 --- a/game.scm +++ b/game.scm @@ -26,6 +26,7 @@ (dom media) (dom window) (game actors) + (game level) (game levels level-1) (game tileset) (goblins core) @@ -54,7 +55,7 @@ 320 240 (inexact->exact tile-width) (inexact->exact tile-height))) -(define* (load-sound-effect name #:key (volume 0.5)) +(define* (load-sound-effect name #:key (volume 0.25)) (let ((audio (make-audio (string-append "assets/sounds/" name ".wav")))) (set-media-volume! audio volume) audio)) @@ -62,6 +63,7 @@ (define audio:push (load-sound-effect "push")) (define audio:undo (load-sound-effect "undo")) (define audio:no (load-sound-effect "no")) +(define audio:exit (load-sound-effect "exit")) ;; Game state (define *actormap* (make-whactormap)) @@ -73,8 +75,6 @@ (define *level* #f) ;; Latest representation of all actors in level (define *grid* #f) -;; Background tile layer. -(define *background* #f) (define *snapshots* '()) (define (clear-snapshots!) @@ -90,25 +90,23 @@ (media-play audio:undo)))) (define (update-grid!) - (set! *grid* ($ *level* 'describe))) + (set! *grid* ($ (level-actor *level*) 'describe))) (define (reset-game!) (set! *actormap* (make-whactormap)) (clear-snapshots!) (with-goblins - (call-with-values load-level-1 - (lambda (background level) - (set! *background* background) - (set! *level* level))) + (set! *level* (load-level-1)) (update-grid!))) ;; Update loop (define (move-player dir) (save-snapshot!) (with-goblins - (match ($ *level* 'move-player dir) + (match ($ (level-actor *level*) 'move-player dir) ('bump (media-play audio:bump)) ('push (media-play audio:push)) + ('exit (media-play audio:exit)) (_ #f)) (update-grid!))) @@ -156,7 +154,7 @@ (_ #f))) (define (draw-clock-emitter x y) - (draw-tile context tileset 2 x y)) + (draw-tile context tileset 48 x y)) (define (draw-object x y obj) (and obj @@ -171,7 +169,7 @@ (('clock-emitter) (draw-clock-emitter x y)))))) (define (draw-background) - (let* ((bv *background*) + (let* ((bv (level-background *level*)) (len (bytevector-length bv))) (let lp ((i 0)) (when (< i len) @@ -210,6 +208,7 @@ (define (on-key-down event) (let ((key (keyboard-event-code event))) + (pk 'key-down key) (cond ((string=? key key:left) (move-player 'left)) @@ -225,10 +224,6 @@ ((string=? key key:confirm) (reset-game!))))) -(define (on-key-up event) - (let ((key (keyboard-event-code event))) - (pk 'key-up key))) - ;; Canvas and event loop setup (define canvas (get-element-by-id "canvas")) (define context (get-context canvas "2d")) @@ -256,8 +251,6 @@ (procedure->external (lambda (_) (resize-canvas)))) (add-event-listener! (current-document) "keydown" (procedure->external on-key-down)) -(add-event-listener! (current-document) "keyup" - (procedure->external on-key-up)) (resize-canvas) (request-animation-frame draw-callback) (timeout update-callback dt) diff --git a/modules/game/actors.scm b/modules/game/actors.scm index 1a9b370..835bd83 100644 --- a/modules/game/actors.scm +++ b/modules/game/actors.scm @@ -1,8 +1,12 @@ (define-module (game actors) #:use-module (goblins core) - #:use-module (hoot bytevectors) #:use-module (ice-9 match) #:export (^cell + ^exit + ^wall + ^block + ^clock-emitter + ^player ^level)) (define* (^cell bcom #:optional val) @@ -17,7 +21,7 @@ (('wire-state) #f) (('set-wire-state) #f) (('describe) '(exit)) - (('collide) 'goal))) + (('collide) 'exit))) (define (^wall bcom type) (match-lambda* @@ -68,8 +72,9 @@ (('wire-state) #f) (('describe) '(player)))) -(define (^level bcom width height objects) +(define (^level bcom width height) (define player (spawn ^player)) + ;; TODO: Move this into the player actor. (define player-coords (spawn ^cell)) (define (make-grid) (make-vector (* width height))) @@ -108,7 +113,11 @@ (occupant (match ($ occupant 'collide) ('bump 'bump) - ('goal (pk 'GOAL)) + ('exit + ($ old-cell #f) + ($ cell player) + ($ player-coords (vector x y)) + 'exit) ('push (let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy))))) (match ($ next-cell) @@ -174,42 +183,6 @@ (lambda (x y) (grid-set! grid x y (spawn ^cell)))) - ;; TODO: actually write levels - (warp-player 10 8) - - ;; Parsed packed object data and spawn objects. - (let ((len (bytevector-length objects))) - (let lp ((i 0)) - (when (< i len) - (let ((x (bytevector-u8-ref objects i)) - (y (bytevector-u8-ref objects (+ i 1))) - (obj (match (bytevector-u8-ref objects (+ i 2)) - (1 (spawn ^wall 'brick)) - (id (error "invalid level object" id))))) - ($ (grid-ref grid x y) obj)) - (lp (+ i 3))))) - - ($ (grid-ref grid 3 7) (spawn ^exit)) - - ($ (grid-ref grid 4 3) (spawn ^clock-emitter 3)) - ($ (grid-ref grid 5 3) (spawn ^wall '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)) - ($ (grid-ref grid 10 3) (spawn ^wall 'copper)) - ($ (grid-ref grid 11 3) (spawn ^wall 'copper)) - ($ (grid-ref grid 12 3) (spawn ^wall 'copper)) - ($ (grid-ref grid 13 2) (spawn ^wall 'copper)) - ($ (grid-ref grid 13 3) (spawn ^wall 'copper)) - ($ (grid-ref grid 13 4) (spawn ^wall 'copper)) - ($ (grid-ref grid 14 2) (spawn ^wall 'copper)) - ($ (grid-ref grid 14 4) (spawn ^wall 'copper)) - ($ (grid-ref grid 15 3) (spawn ^wall 'copper)) - ($ (grid-ref grid 16 3) (spawn ^wall 'copper)) - ($ (grid-ref grid 17 3) (spawn ^wall 'copper)) - ($ (grid-ref grid 18 3) (spawn ^wall 'copper)) - (match-lambda* (('describe) (let ((grid* (make-grid))) @@ -220,6 +193,11 @@ (#f #f) (refr ($ refr 'describe)))))) grid*)) + (('set-object x y obj) + ($ (grid-ref grid x y) obj)) + ;; TODO: Move to player actor + (('warp-player x y) + (warp-player x y)) (('move-player dir) (define result (match dir diff --git a/modules/game/level.scm b/modules/game/level.scm new file mode 100644 index 0000000..f8ef450 --- /dev/null +++ b/modules/game/level.scm @@ -0,0 +1,40 @@ +(define-module (game level) + #:use-module (game actors) + #:use-module (goblins core) + #:use-module (hoot bytevectors) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:export (make-level + level? + level-background + level-actor)) + +;; Client-side rendering info coupled with level actor that contains +;; game state. +(define-record-type + (%make-level background actor) + level? + (background level-background) + (actor level-actor)) + +(define (make-level width height background objects) + (let ((level* (spawn ^level width height))) + ;; Parsed packed object data and spawn objects. + (let ((len (bytevector-length objects))) + (let lp ((i 0)) + (when (< i len) + (let ((x (bytevector-u8-ref objects i)) + (y (bytevector-u8-ref objects (+ i 1))) + (id (bytevector-u8-ref objects (+ i 2)))) + (if (= id 3) ; player-spawn + ($ level* 'warp-player x y) + (let ((obj (match id + (1 (spawn ^wall 'brick)) + (2 (spawn ^wall 'copper)) + (4 (spawn ^exit)) + (5 (spawn ^block 'copper)) + (6 (spawn ^clock-emitter 4)) + (id (error "invalid level object" id))))) + ($ level* 'set-object x y obj)))) + (lp (+ i 3))))) + (%make-level background level*))) diff --git a/modules/game/levels/level-1.tmx b/modules/game/levels/level-1.tmx index 39c4e24..d3b3bc1 100644 --- a/modules/game/levels/level-1.tmx +++ b/modules/game/levels/level-1.tmx @@ -1,14 +1,14 @@ - + 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, 23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23, -23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, +23,23,24,24,24,24,24,24,24,28,24,24,24,24,24,24,24,24,23,23, +23,24,24,24,24,24,24,24,24,24,24,24,3,3,24,24,24,24,24,23, +23,49,3,3,3,3,24,3,3,3,3,3,3,24,3,3,3,3,3,23, +23,24,24,24,24,24,24,24,24,24,24,24,3,3,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, @@ -20,4 +20,12 @@ 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23 + + + + + + + + diff --git a/modules/game/levels/tiles.tsx b/modules/game/levels/tiles.tsx index 2e52cd6..75f1cf3 100644 --- a/modules/game/levels/tiles.tsx +++ b/modules/game/levels/tiles.tsx @@ -1,9 +1,16 @@ - + - + + + + + + + + diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm index 7c83542..4468a0b 100644 --- a/scripts/compile-map.scm +++ b/scripts/compile-map.scm @@ -93,9 +93,10 @@ (loop (+ i 1) (+ t d))))))) (define-record-type - (make-tile id image animation properties) + (make-tile id type image animation properties) tile? (id tile-id) + (type tile-type) (image tile-image) (animation tile-animation) (properties tile-properties)) @@ -141,9 +142,10 @@ ((= i (vector-length tiles))) (let* ((id (+ first-gid i)) (custom (or (assv-ref custom-tiles id) '())) + (type (assq-ref custom 'type)) (animation (assq-ref custom 'animation)) (properties (assq-ref custom 'properties)) - (tile (make-tile id i + (tile (make-tile id type i (and animation (make-animation image first-gid animation)) (or properties '())))) @@ -351,9 +353,11 @@ the default ORIENTATION value of 'orthogonal' is supported." (define (parse-tileset node first-gid) (define (parse-custom-tile node) (let ((id (attr node 'id string->number)) + (type (attr node 'type)) (properties (map parse-property ((sxpath '(properties property)) node)))) - `(,id . ((properties . ,properties))))) + `(,id . (,@(if type `((type . ,type)) '()) + (properties . ,properties))))) (let* ((name (attr node 'name)) (tile-width (attr node 'tilewidth string->number)) (tile-height (attr node 'tileheight string->number)) @@ -541,42 +545,54 @@ the default ORIENTATION value of 'orthogonal' is supported." (iota (tile-layer-width layer)))) (iota (tile-layer-height layer)))))) -(define (compile-walls tile-map layer-name) +(define obj:wall:brick 1) +(define obj:wall:copper 2) +(define obj:player-spawn 3) +(define obj:exit 4) +(define obj:block:copper 5) +(define obj:clock-emitter 6) + +(define (compile-environment-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))) - (u8-list->bytevector - (append-map (lambda (y) - (concatenate - (filter-map (lambda (x) - (match (tile-layer-ref layer x y) - (#f #f) - (tile - (and (assq-ref (tile-properties (map-tile-ref tile)) 'wall) - (list x y 1))))) - (iota (tile-layer-width layer))))) - (iota (tile-layer-height layer)))))) + (append-map (lambda (y) + (concatenate + (filter-map (lambda (x) + (match (tile-layer-ref layer x y) + (#f #f) + ((= map-tile-ref tile) + (match (tile-type tile) + (#f #f) + ("wall" + (match (assq-ref (tile-properties tile) 'kind) + ("brick" (list x y obj:wall:brick)) + ("copper" (list x y obj:wall:copper)) + (kind (error "unsupported wall kind" kind)))) + ("exit" (list x y obj:exit)) + ("clock-emitter" (list x y obj:clock-emitter)) + (type (error "unsupported background object" type)))))) + (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 (compile-object-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))) + (append-map (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))) + (match type + ('player-spawn (list x y obj:player-spawn)) + ('block + (match (assq-ref properties 'kind) + ("copper" (list x y obj:block:copper)) + (kind (error "unsupported block kind" kind)))) + (_ (error "unsupported object type" type))))) + (object-layer-objects layer)))) (define (basename-strip-extension file-name) (match (string-split (basename file-name) #\.) @@ -588,16 +604,17 @@ the default ORIENTATION value of 'orthogonal' is supported." (module-name `(game levels ,(string->symbol name))) (proc-name (string->symbol (string-append "load-" name))) (tile-map (load-tile-map file-name))) + (compile-object-layer tile-map "objects") (for-each pretty-print `((define-module ,module-name - #:use-module (game actors) - #:use-module (goblins core) - #:use-module (math vector) + #:use-module (game level) #: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) - ,(compile-walls tile-map "background")))))))) + (make-level ,(tile-map-width tile-map) + ,(tile-map-height tile-map) + ,(compile-tile-layer tile-map "background") + ,(u8-list->bytevector + (append + (compile-environment-layer tile-map "background") + (compile-object-layer tile-map "objects"))))))))) (_ (error "file name expected")))