diff --git a/.gitignore b/.gitignore index 74967b6..2f1ce4b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ /game.wasm /modules/game/levels/*.scm +/cirkoban.zip diff --git a/Makefile b/Makefile index 0eb626c..501999d 100644 --- a/Makefile +++ b/Makefile @@ -17,6 +17,7 @@ modules = \ modules/ice-9/control.scm \ modules/ice-9/q.scm \ modules/ice-9/vlist.scm \ + modules/local-storage.scm \ modules/math.scm \ modules/math/rect.scm \ modules/math/vector.scm \ @@ -39,8 +40,8 @@ serve: game.wasm guile -c '((@ (hoot web-server) serve))' bundle: game.wasm - rm game.zip || true - zip game.zip -r assets/ reflect.js game.js game.css reflect.wasm wtf8.wasm game.wasm index.html + rm cirkoban.zip || true + zip cirkoban.zip -r assets/ reflect.js game.js game.css reflect.wasm wtf8.wasm game.wasm index.html clean: rm -f game.wasm game.zip diff --git a/game.js b/game.js index 31411ba..e063178 100644 --- a/game.js +++ b/game.js @@ -43,6 +43,10 @@ window.addEventListener("load", async () => { return img; } }, + localStorage: { + getItem: (key) => localStorage.getItem(key) || "", + setItem: (key, value) => localStorage.setItem(key, value) + }, media: { newAudio: (src) => new Audio(src), play: (media) => media.play(), diff --git a/game.scm b/game.scm index 440247c..9a35851 100644 --- a/game.scm +++ b/game.scm @@ -36,6 +36,7 @@ (hoot ffi) (hoot hashtables) (ice-9 match) + (local-storage) (math) (math rect) (math vector)) @@ -84,7 +85,7 @@ (define *level-idx* #f) (define *level* #f) ;; Latest representation of all actors in level -(define *grid* #f) +(define *objects* #f) (define *snapshots* '()) (define (clear-snapshots!) @@ -99,38 +100,73 @@ (set! *snapshots* older-snapshots) (media-play audio:undo)))) -(define (update-grid!) - (set! *grid* ($ (level-actor *level*) 'describe))) +(define (update-objects!) + (set! *objects* + ;; TODO: Receive layer for sprite sorting + (map (match-lambda + ((type #(x y) . properties) + `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties))) + ($ (level-actor *level*) 'describe)))) -(define (next-level!) - (clear-snapshots!) - (let ((idx (+ *level-idx* 1))) - (set! *level-idx* idx) - (if (< idx (vector-length levels)) - (set! *level* ((vector-ref levels idx))) - (set! *state* 'win)))) - -(define (reset-game!) +(define (load-level! idx) (set! *state* 'play) (set! *actormap* (make-whactormap)) (clear-snapshots!) - (set! *level-idx* -1) (with-goblins - (next-level!) - (update-grid!))) + (set! *level* ((vector-ref levels idx))) + (update-objects!))) + +(define (next-level!) + (let ((idx (+ *level-idx* 1))) + (pk 'next-level idx) + (set! *level-idx* idx) + (if (< idx (vector-length levels)) + (begin + (save-game!) + (load-level! idx)) + (set! *state* 'win)))) + +;; Auto-save/load to local storage. +(define (save-game!) + (pk 'save) + (local-storage-set! "cirkoban-level" (number->string *level-idx*))) + +(define (load-game!) + (set! *level-idx* + (match (local-storage-ref "cirkoban-level") + ("" 0) + (str (string->number str)))) + (pk 'load *level-idx*) + (load-level! *level-idx*)) + +(define (reset-game!) + (set! *level-idx* 0) + (save-game!) + (load-level! 0)) ;; Update loop (define (move-player dir) + (define (do-move) + (with-goblins + ($ (level-player *level*) 'move dir) + ($ (level-actor *level*) 'tick) + (define result + (match (pk 'event ($ (level-player *level*) 'event)) + (('bump) + (media-play audio:bump) + #f) + (('push) + (media-play audio:push) + #f) + (('exit) + (media-play audio:exit) + 'next-level) + (_ #f))) + (update-objects!) + result)) (save-snapshot!) - (with-goblins - (match ($ (level-actor *level*) 'move-player dir) - ('bump (media-play audio:bump)) - ('push (media-play audio:push)) - ('exit - (media-play audio:exit) - (next-level!)) - (_ #f)) - (update-grid!))) + (when (eq? (do-move) 'next-level) + (next-level!))) (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz (define (update) @@ -147,50 +183,51 @@ (hashtable-set! cache x str) str))))) -(define (draw-player x y) - (draw-tile context tileset 0 x y)) +(define (draw-player pos) + (draw-tile context tileset 0 (vec2-x pos) (vec2-y pos))) -(define (draw-exit x y) - (draw-tile context tileset 27 x y)) +(define (draw-exit pos) + (draw-tile context tileset 27 (vec2-x pos) (vec2-y pos))) -(define (draw-wall type x y) - (match type - ('brick - (draw-tile context tileset 22 x y)) - (_ - (draw-tile context tileset 2 x y))) - (match type - ('electron-head - (draw-tile context tileset 4 x y)) - ('electron-tail - (draw-tile context tileset 5 x y)) - (_ #f))) +(define (draw-wall type pos) + (let ((x (vec2-x pos)) + (y (vec2-y pos))) + (match type + ('brick + (draw-tile context tileset 22 x y)) + (_ + (draw-tile context tileset 2 x y))) + (match type + ('electron-head + (draw-tile context tileset 4 x y)) + ('electron-tail + (draw-tile context tileset 5 x y)) + (_ #f)))) -(define (draw-block type x y) - (match type - ('crate (draw-tile context tileset 29 x y)) - ('copper (draw-tile context tileset 3 x y))) - (match type - ('electron-head - (draw-tile context tileset 4 x y)) - ('electron-tail - (draw-tile context tileset 5 x y)) - (_ #f))) +(define (draw-block type pos) + (let ((x (vec2-x pos)) + (y (vec2-y pos))) + (match type + ('crate (draw-tile context tileset 29 x y)) + (_ (draw-tile context tileset 3 x y))) + (match type + ('electron-head + (draw-tile context tileset 4 x y)) + ('electron-tail + (draw-tile context tileset 5 x y)) + (_ #f)))) -(define (draw-clock-emitter x y) - (draw-tile context tileset 48 x y)) +(define (draw-clock-emitter pos) + (draw-tile context tileset 48 (vec2-x pos) (vec2-y pos))) -(define (draw-object x y obj) - (and obj - (let ((x (* x tile-width)) - (y (* y tile-height))) - (match obj - (#f #f) - (('player) (draw-player x y)) - (('exit) (draw-exit x y)) - (('wall type) (draw-wall type x y)) - (('block type) (draw-block type x y)) - (('clock-emitter) (draw-clock-emitter x y)))))) +(define (draw-object obj) + (match obj + (#f #f) + (('player pos) (draw-player pos)) + (('exit pos) (draw-exit pos)) + (('wall pos type) (draw-wall type pos)) + (('block pos type) (draw-block type pos)) + (('clock-emitter pos) (draw-clock-emitter pos)))) (define (draw-background) (let* ((bv (level-background *level*)) @@ -205,14 +242,7 @@ (define (draw-level) (draw-background) - (let ((grid *grid*)) - (let y-loop ((y 0)) - (when (< y level-height) - (let x-loop ((x 0)) - (when (< x level-width) - (draw-object x y (vector-ref grid (+ (* y level-width) x))) - (x-loop (1+ x)))) - (y-loop (1+ y)))))) + (for-each draw-object *objects*)) (define (draw-win) (set-fill-color! context "#x000000") @@ -252,9 +282,7 @@ (move-player 'down)) ((string=? key key:undo) (rollback-snapshot!) - (with-goblins (update-grid!))) - ((string=? key key:confirm) - (reset-game!)))) + (with-goblins (update-objects!))))) ('win (cond ((string=? key key:confirm) @@ -290,4 +318,4 @@ (resize-canvas) (request-animation-frame draw-callback) (timeout update-callback dt) -(reset-game!) +(load-game!) diff --git a/modules/game/actors.scm b/modules/game/actors.scm index 835bd83..dde0007 100644 --- a/modules/game/actors.scm +++ b/modules/game/actors.scm @@ -15,16 +15,27 @@ ((new-val) (bcom (^cell bcom new-val))))) -(define (^exit bcom) +;; TODO: Add layer info to 'describe' output for sorting sprites when +;; rendering. + +;; TODO: Port actor-lib methods and use it. +(define (^exit bcom x y) + (define position (vector x y)) (match-lambda* + (('type) 'exit) + (('position) position) (('tick) #f) (('wire-state) #f) (('set-wire-state) #f) - (('describe) '(exit)) - (('collide) 'exit))) + (('describe) `(exit ,position)) + (('collide other offset grid-info) #f))) -(define (^wall bcom type) +;; TODO: Maybe make separate actors for conductive vs. inert walls. +(define (^wall bcom x y type) + (define position (vector x y)) (match-lambda* + (('type) 'wall) + (('position) position) (('tick) #f) (('wire-state) (match type @@ -32,26 +43,47 @@ type) (_ #f))) (('set-wire-state type) - (bcom (^wall bcom type))) - (('describe) `(wall ,type)) - (('collide) 'bump))) + (bcom (^wall bcom x y type))) + (('describe) `(wall ,position ,type)) + (('collide other offset grid-info) #f))) -(define (^block bcom type) +;; TODO: Maybe make separate actors for conductive vs. inert blocks. +(define (^block bcom x y type) + (define position (spawn ^cell (vector x y))) + (define pushed? (spawn ^cell)) (match-lambda* - (('tick) #f) + (('type) 'block) + (('position) ($ position)) + (('tick) ($ pushed? #f)) (('wire-state) (match type ((or 'copper 'electron-head 'electron-tail) type) (_ #f))) (('set-wire-state type) - (bcom (^block bcom type))) - (('describe) `(block ,type)) - (('collide) 'push))) + (match ($ position) + (#(x y) + (bcom (^block bcom x y type))))) + (('describe) `(block ,($ position) ,type)) + (('collide other offset grid-info) + ;; TODO: Only push if there's not a wall in the destination. + (match ($ position) + (#(x y) + (match offset + (#(dx dy) + (let ((x (+ x dx)) + (y (+ y dy))) + (unless ($ grid-info 'occupied? x y) + ($ pushed? #t) + ($ position (vector x y))))))))) + (('pushed?) ($ pushed?)))) -(define (^clock-emitter bcom interval) +(define (^clock-emitter bcom x y interval) (define timer (spawn ^cell 0)) + (define position (vector x y)) (match-lambda* + (('type) 'emitter) + (('position) position) (('tick) ($ timer (+ ($ timer) 1))) (('wire-state) (let ((t ($ timer))) @@ -63,28 +95,58 @@ (else 'copper)))) (('set-wire-state type) #f) - (('describe) '(clock-emitter)) - (('collide) 'bump))) + (('describe) `(clock-emitter ,position)) + (('collide other offset grid-info) #f))) -(define (^player bcom) +(define (^player bcom x y) + (define position (spawn ^cell (vector x y))) + (define velocity (spawn ^cell #(0 0))) + (define event (spawn ^cell)) (match-lambda* - (('tick) #f) + (('type) 'player) + (('position) ($ position)) + (('move dir) + ($ velocity + (match dir + ('left #(-1 0)) + ('right #(1 0)) + ('up #(0 -1)) + ('down #(0 1)) + (_ (error "invalid direction" dir))))) + (('tick) + ($ event #f) + (match ($ position) + (#(x y) + (match ($ velocity) + (#(dx dy) + ($ position (vector (+ x dx) (+ y dy))) + ($ velocity #(0 0))))))) (('wire-state) #f) - (('describe) '(player)))) + (('describe) `(player ,($ position))) + (('collide other offset grid-info) + (define (reverse-move) + (match ($ position) + (#(x y) + (match offset + (#(dx dy) + ($ position (vector (- x dx) (- y dy)))))))) + (match ($ other 'type) + ('exit ($ event '(exit))) + ('block + (if ($ other 'pushed?) + ($ event '(push)) + (begin + (reverse-move) + ($ event '(bump))))) + (_ + (reverse-move) + ($ event '(bump))))) + (('event) ($ event)))) (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))) - (define grid (make-grid)) - (define (grid-ref grid x y) - (vector-ref grid (+ (* y width) x))) - (define (grid-ref/wrap grid x y) - (grid-ref grid (modulo x width) (modulo y height))) - (define (grid-set! grid x y val) - (vector-set! grid (+ (* y width) x) val)) + (define objects (spawn ^cell '())) + + ;; Spatial partition (define (for-each-coord proc) (let y-loop ((y 0)) (when (< y height) @@ -93,55 +155,74 @@ (proc x y) (x-loop (1+ x)))) (y-loop (1+ y))))) + (define (make-grid init) + (let ((grid (make-vector (* width height)))) + (for-each-coord + (lambda (x y) + (grid-set! grid x y (spawn ^cell init)))) + grid)) + (define (grid-ref grid x y) + (vector-ref grid (+ (* y width) x))) + (define (grid-ref/wrap grid x y) + (grid-ref grid (modulo x width) (modulo y height))) + (define (grid-set! grid x y val) + (vector-set! grid (+ (* y width) x) val)) + (define grid (make-grid '())) + + ;; Read-only access to query the grid. + (define (^grid-info bcom) + (match-lambda* + (('occupied? x y) + (not (null? ($ (grid-ref grid x y))))))) + (define grid-info (spawn ^grid-info)) + (define (wrap-x x) (modulo x width)) (define (wrap-y y) (modulo y height)) - ;; Assumes that dx/dy are in the range [0,1]. - (define (move-player dx dy) - (match ($ player-coords) - (#(old-x old-y) - (let* ((x (wrap-x (+ old-x dx))) - (y (wrap-y (+ old-y dy))) - (old-cell (grid-ref grid old-x old-y)) - (cell (grid-ref grid x y))) - (match ($ cell) - (#f - ($ old-cell #f) - ($ cell player) - ($ player-coords (vector x y))) - (occupant - (match ($ occupant 'collide) - ('bump 'bump) - ('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) - (#f - ($ next-cell ($ cell)) - ($ cell player) - ($ old-cell #f) - ($ player-coords (vector x y)) - 'push) - (_ #f))))))))))) - (define (warp-player x y) - ($ (grid-ref grid x y) player) - (match ($ player-coords) - (#f - ($ player-coords (vector x y))) - (#(old-x old-y) - ($ player-coords (vector x y)) - ($ (grid-ref grid old-x old-y) #f)))) + (define (delq item lst) + (let lp ((lst lst)) + (match lst + (() '()) + ((head . tail) + (if (eq? item head) + tail + (cons head (lp tail))))))) + (define (maybe-update-grid obj prev-pos resolved-pos) + (unless (equal? prev-pos resolved-pos) + (match prev-pos + (#(x y) + (let ((cell (grid-ref grid x y))) + ($ cell (delq obj ($ cell)))))) + (match resolved-pos + (#(x y) + (let ((cell (grid-ref grid x y))) + ($ cell (cons obj ($ cell)))))))) + (define (collide obj pos prev-pos) + (match pos + (#(x y) + (let lp ((objects ($ (grid-ref grid x y)))) + (match objects + (() (maybe-update-grid obj prev-pos ($ obj 'position))) + ((other . rest) + (if (eq? obj other) + (lp rest) + (let ((other-prev-pos ($ other 'position))) + (match prev-pos + (#(prev-x prev-y) + (let ((offset (vector (- x prev-x) (- y prev-y)))) + (pk 'collision! ($ obj 'type) ($ other 'type)) + ($ other 'collide obj offset grid-info) + ($ obj 'collide other offset grid-info) + (maybe-update-grid other other-prev-pos ($ other 'position)) + (lp rest)))))))))))) (define (tick) (define (neighbors x y) (define (check x y) (match ($ (grid-ref/wrap grid x y)) - (#f 0) - (refr + (() 0) + ;; TODO: Handle tiles with many occupants. + ((refr . _) (match ($ refr 'wire-state) ('electron-head 1) (_ 0))))) @@ -153,6 +234,16 @@ (check x (+ y 1)) (check (- x 1) (+ y 1)) (check (- x 1) y))) + ;; Tick each object and check for collisions. + (for-each (lambda (obj) + (let ((prev-pos ($ obj 'position))) + ($ obj 'tick) + ;; Only check collisions for movable objects. + (let ((desired-pos ($ obj 'position))) + (unless (equal? prev-pos desired-pos) + (collide obj desired-pos prev-pos))))) + ($ objects)) + ;; Advance Wirewold simulation. (for-each (match-lambda ((refr . wire-state) ($ refr 'set-wire-state wire-state))) @@ -162,9 +253,9 @@ (let x-loop ((x 0) (updates updates)) (if (< x width) (match ($ (grid-ref grid x y)) - (#f (x-loop (1+ x) updates)) - (refr - ($ refr 'tick) + (() (x-loop (1+ x) updates)) + ;; TODO: Handle many occupants + ((refr . _) (match ($ refr 'wire-state) (#f (x-loop (1+ x) updates)) ('copper @@ -178,32 +269,13 @@ updates))) updates)))) - ;; Initialize grid cells - (for-each-coord - (lambda (x y) - (grid-set! grid x y (spawn ^cell)))) - (match-lambda* + (('tick) (tick)) (('describe) - (let ((grid* (make-grid))) - (for-each-coord - (lambda (x y) - (grid-set! grid* x y - (match ($ (grid-ref grid x y)) - (#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 - ('up (move-player 0 -1)) - ('down (move-player 0 1)) - ('left (move-player -1 0)) - ('right (move-player 1 0)))) - (tick) - result))) + (map (lambda (obj) ($ obj 'describe)) ($ objects))) + (('add-object obj) + ($ objects (cons obj ($ objects))) + (match ($ obj 'position) + (#(x y) + (let ((cell (grid-ref grid x y))) + ($ cell (cons obj ($ cell))))))))) diff --git a/modules/game/level.scm b/modules/game/level.scm index 6d2bf20..50c9710 100644 --- a/modules/game/level.scm +++ b/modules/game/level.scm @@ -7,37 +7,39 @@ #:export (make-level level? level-background - level-actor)) + level-actor + level-player)) ;; Client-side rendering info coupled with level actor that contains ;; game state. (define-record-type - (%make-level background actor) + (%make-level background actor player) level? (background level-background) - (actor level-actor)) + (actor level-actor) + (player level-player)) (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)) + (let ((level* (spawn ^level width height)) + (len (bytevector-length objects))) + ;; Parsed packed object data and spawn objects, making special + ;; note of the player. + (let lp ((i 0) (player #f)) + (if (< i len) + (let* ((x (bytevector-u8-ref objects i)) (y (bytevector-u8-ref objects (+ i 1))) - (id (bytevector-u8-ref objects (+ i 2)))) + (id (bytevector-u8-ref objects (+ i 2))) + (obj (match id + (1 (spawn ^wall x y 'brick)) + (2 (spawn ^wall x y 'copper)) + (3 (spawn ^player x y)) + (4 (spawn ^exit x y)) + (5 (spawn ^block x y 'copper)) + (6 (spawn ^block x y 'crate)) + (7 (spawn ^clock-emitter x y 4)) + (id (error "invalid level object" id))))) + ($ level* 'add-object obj) (if (= id 3) ; player-spawn - (begin - (pk 'spawn-player x y) - ($ 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 ^block 'crate)) - (7 (spawn ^clock-emitter 4)) - (id (error "invalid level object" id))))) - ($ level* 'set-object x y obj)))) - (lp (+ i 3))))) - (%make-level background level*))) + (lp (+ i 3) obj) + (lp (+ i 3) player))) + (%make-level background level* player))))) diff --git a/modules/local-storage.scm b/modules/local-storage.scm new file mode 100644 index 0000000..43dd723 --- /dev/null +++ b/modules/local-storage.scm @@ -0,0 +1,11 @@ +(define-module (local-storage) + #:use-module (hoot ffi) + #:export (local-storage-ref + local-storage-set!)) + +(define-foreign local-storage-ref + "localStorage" "getItem" + (ref string) -> (ref string)) +(define-foreign local-storage-set! + "localStorage" "setItem" + (ref string) (ref string) -> none)