Big actor refactor; use local storage for auto-save.

This commit is contained in:
David Thompson 2024-05-20 22:12:35 -04:00
parent ce0c002e8b
commit 816d9d149d
7 changed files with 321 additions and 202 deletions

1
.gitignore vendored
View file

@ -1,2 +1,3 @@
/game.wasm /game.wasm
/modules/game/levels/*.scm /modules/game/levels/*.scm
/cirkoban.zip

View file

@ -17,6 +17,7 @@ modules = \
modules/ice-9/control.scm \ modules/ice-9/control.scm \
modules/ice-9/q.scm \ modules/ice-9/q.scm \
modules/ice-9/vlist.scm \ modules/ice-9/vlist.scm \
modules/local-storage.scm \
modules/math.scm \ modules/math.scm \
modules/math/rect.scm \ modules/math/rect.scm \
modules/math/vector.scm \ modules/math/vector.scm \
@ -39,8 +40,8 @@ serve: game.wasm
guile -c '((@ (hoot web-server) serve))' guile -c '((@ (hoot web-server) serve))'
bundle: game.wasm bundle: game.wasm
rm game.zip || true rm cirkoban.zip || true
zip game.zip -r assets/ reflect.js game.js game.css reflect.wasm wtf8.wasm game.wasm index.html zip cirkoban.zip -r assets/ reflect.js game.js game.css reflect.wasm wtf8.wasm game.wasm index.html
clean: clean:
rm -f game.wasm game.zip rm -f game.wasm game.zip

View file

@ -43,6 +43,10 @@ window.addEventListener("load", async () => {
return img; return img;
} }
}, },
localStorage: {
getItem: (key) => localStorage.getItem(key) || "",
setItem: (key, value) => localStorage.setItem(key, value)
},
media: { media: {
newAudio: (src) => new Audio(src), newAudio: (src) => new Audio(src),
play: (media) => media.play(), play: (media) => media.play(),

138
game.scm
View file

@ -36,6 +36,7 @@
(hoot ffi) (hoot ffi)
(hoot hashtables) (hoot hashtables)
(ice-9 match) (ice-9 match)
(local-storage)
(math) (math)
(math rect) (math rect)
(math vector)) (math vector))
@ -84,7 +85,7 @@
(define *level-idx* #f) (define *level-idx* #f)
(define *level* #f) (define *level* #f)
;; Latest representation of all actors in level ;; Latest representation of all actors in level
(define *grid* #f) (define *objects* #f)
(define *snapshots* '()) (define *snapshots* '())
(define (clear-snapshots!) (define (clear-snapshots!)
@ -99,38 +100,73 @@
(set! *snapshots* older-snapshots) (set! *snapshots* older-snapshots)
(media-play audio:undo)))) (media-play audio:undo))))
(define (update-grid!) (define (update-objects!)
(set! *grid* ($ (level-actor *level*) 'describe))) (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!) (define (load-level! idx)
(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!)
(set! *state* 'play) (set! *state* 'play)
(set! *actormap* (make-whactormap)) (set! *actormap* (make-whactormap))
(clear-snapshots!) (clear-snapshots!)
(set! *level-idx* -1)
(with-goblins (with-goblins
(next-level!) (set! *level* ((vector-ref levels idx)))
(update-grid!))) (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 ;; Update loop
(define (move-player dir) (define (move-player dir)
(save-snapshot!) (define (do-move)
(with-goblins (with-goblins
(match ($ (level-actor *level*) 'move-player dir) ($ (level-player *level*) 'move dir)
('bump (media-play audio:bump)) ($ (level-actor *level*) 'tick)
('push (media-play audio:push)) (define result
('exit (match (pk 'event ($ (level-player *level*) 'event))
(('bump)
(media-play audio:bump)
#f)
(('push)
(media-play audio:push)
#f)
(('exit)
(media-play audio:exit) (media-play audio:exit)
(next-level!)) 'next-level)
(_ #f)) (_ #f)))
(update-grid!))) (update-objects!)
result))
(save-snapshot!)
(when (eq? (do-move) 'next-level)
(next-level!)))
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update) (define (update)
@ -147,13 +183,15 @@
(hashtable-set! cache x str) (hashtable-set! cache x str)
str))))) str)))))
(define (draw-player x y) (define (draw-player pos)
(draw-tile context tileset 0 x y)) (draw-tile context tileset 0 (vec2-x pos) (vec2-y pos)))
(define (draw-exit x y) (define (draw-exit pos)
(draw-tile context tileset 27 x y)) (draw-tile context tileset 27 (vec2-x pos) (vec2-y pos)))
(define (draw-wall type x y) (define (draw-wall type pos)
(let ((x (vec2-x pos))
(y (vec2-y pos)))
(match type (match type
('brick ('brick
(draw-tile context tileset 22 x y)) (draw-tile context tileset 22 x y))
@ -164,33 +202,32 @@
(draw-tile context tileset 4 x y)) (draw-tile context tileset 4 x y))
('electron-tail ('electron-tail
(draw-tile context tileset 5 x y)) (draw-tile context tileset 5 x y))
(_ #f))) (_ #f))))
(define (draw-block type x y) (define (draw-block type pos)
(let ((x (vec2-x pos))
(y (vec2-y pos)))
(match type (match type
('crate (draw-tile context tileset 29 x y)) ('crate (draw-tile context tileset 29 x y))
('copper (draw-tile context tileset 3 x y))) (_ (draw-tile context tileset 3 x y)))
(match type (match type
('electron-head ('electron-head
(draw-tile context tileset 4 x y)) (draw-tile context tileset 4 x y))
('electron-tail ('electron-tail
(draw-tile context tileset 5 x y)) (draw-tile context tileset 5 x y))
(_ #f))) (_ #f))))
(define (draw-clock-emitter x y) (define (draw-clock-emitter pos)
(draw-tile context tileset 48 x y)) (draw-tile context tileset 48 (vec2-x pos) (vec2-y pos)))
(define (draw-object x y obj) (define (draw-object obj)
(and obj
(let ((x (* x tile-width))
(y (* y tile-height)))
(match obj (match obj
(#f #f) (#f #f)
(('player) (draw-player x y)) (('player pos) (draw-player pos))
(('exit) (draw-exit x y)) (('exit pos) (draw-exit pos))
(('wall type) (draw-wall type x y)) (('wall pos type) (draw-wall type pos))
(('block type) (draw-block type x y)) (('block pos type) (draw-block type pos))
(('clock-emitter) (draw-clock-emitter x y)))))) (('clock-emitter pos) (draw-clock-emitter pos))))
(define (draw-background) (define (draw-background)
(let* ((bv (level-background *level*)) (let* ((bv (level-background *level*))
@ -205,14 +242,7 @@
(define (draw-level) (define (draw-level)
(draw-background) (draw-background)
(let ((grid *grid*)) (for-each draw-object *objects*))
(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))))))
(define (draw-win) (define (draw-win)
(set-fill-color! context "#x000000") (set-fill-color! context "#x000000")
@ -252,9 +282,7 @@
(move-player 'down)) (move-player 'down))
((string=? key key:undo) ((string=? key key:undo)
(rollback-snapshot!) (rollback-snapshot!)
(with-goblins (update-grid!))) (with-goblins (update-objects!)))))
((string=? key key:confirm)
(reset-game!))))
('win ('win
(cond (cond
((string=? key key:confirm) ((string=? key key:confirm)
@ -290,4 +318,4 @@
(resize-canvas) (resize-canvas)
(request-animation-frame draw-callback) (request-animation-frame draw-callback)
(timeout update-callback dt) (timeout update-callback dt)
(reset-game!) (load-game!)

View file

@ -15,16 +15,27 @@
((new-val) ((new-val)
(bcom (^cell bcom 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* (match-lambda*
(('type) 'exit)
(('position) position)
(('tick) #f) (('tick) #f)
(('wire-state) #f) (('wire-state) #f)
(('set-wire-state) #f) (('set-wire-state) #f)
(('describe) '(exit)) (('describe) `(exit ,position))
(('collide) 'exit))) (('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* (match-lambda*
(('type) 'wall)
(('position) position)
(('tick) #f) (('tick) #f)
(('wire-state) (('wire-state)
(match type (match type
@ -32,26 +43,47 @@
type) type)
(_ #f))) (_ #f)))
(('set-wire-state type) (('set-wire-state type)
(bcom (^wall bcom type))) (bcom (^wall bcom x y type)))
(('describe) `(wall ,type)) (('describe) `(wall ,position ,type))
(('collide) 'bump))) (('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* (match-lambda*
(('tick) #f) (('type) 'block)
(('position) ($ position))
(('tick) ($ pushed? #f))
(('wire-state) (('wire-state)
(match type (match type
((or 'copper 'electron-head 'electron-tail) ((or 'copper 'electron-head 'electron-tail)
type) type)
(_ #f))) (_ #f)))
(('set-wire-state type) (('set-wire-state type)
(bcom (^block bcom type))) (match ($ position)
(('describe) `(block ,type)) (#(x y)
(('collide) 'push))) (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 timer (spawn ^cell 0))
(define position (vector x y))
(match-lambda* (match-lambda*
(('type) 'emitter)
(('position) position)
(('tick) ($ timer (+ ($ timer) 1))) (('tick) ($ timer (+ ($ timer) 1)))
(('wire-state) (('wire-state)
(let ((t ($ timer))) (let ((t ($ timer)))
@ -63,28 +95,58 @@
(else (else
'copper)))) 'copper))))
(('set-wire-state type) #f) (('set-wire-state type) #f)
(('describe) '(clock-emitter)) (('describe) `(clock-emitter ,position))
(('collide) 'bump))) (('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* (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) (('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 (^level bcom width height)
(define player (spawn ^player)) (define objects (spawn ^cell '()))
;; TODO: Move this into the player actor.
(define player-coords (spawn ^cell)) ;; Spatial partition
(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 (for-each-coord proc) (define (for-each-coord proc)
(let y-loop ((y 0)) (let y-loop ((y 0))
(when (< y height) (when (< y height)
@ -93,55 +155,74 @@
(proc x y) (proc x y)
(x-loop (1+ x)))) (x-loop (1+ x))))
(y-loop (1+ y))))) (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) (define (wrap-x x)
(modulo x width)) (modulo x width))
(define (wrap-y y) (define (wrap-y y)
(modulo y height)) (modulo y height))
;; Assumes that dx/dy are in the range [0,1]. (define (delq item lst)
(define (move-player dx dy) (let lp ((lst lst))
(match ($ player-coords) (match lst
(#(old-x old-y) (() '())
(let* ((x (wrap-x (+ old-x dx))) ((head . tail)
(y (wrap-y (+ old-y dy))) (if (eq? item head)
(old-cell (grid-ref grid old-x old-y)) tail
(cell (grid-ref grid x y))) (cons head (lp tail)))))))
(match ($ cell) (define (maybe-update-grid obj prev-pos resolved-pos)
(#f (unless (equal? prev-pos resolved-pos)
($ old-cell #f) (match prev-pos
($ cell player) (#(x y)
($ player-coords (vector x y))) (let ((cell (grid-ref grid x y)))
(occupant ($ cell (delq obj ($ cell))))))
(match ($ occupant 'collide) (match resolved-pos
('bump 'bump) (#(x y)
('exit (let ((cell (grid-ref grid x y)))
($ old-cell #f) ($ cell (cons obj ($ cell))))))))
($ cell player) (define (collide obj pos prev-pos)
($ player-coords (vector x y)) (match pos
'exit) (#(x y)
('push (let lp ((objects ($ (grid-ref grid x y))))
(let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy))))) (match objects
(match ($ next-cell) (() (maybe-update-grid obj prev-pos ($ obj 'position)))
(#f ((other . rest)
($ next-cell ($ cell)) (if (eq? obj other)
($ cell player) (lp rest)
($ old-cell #f) (let ((other-prev-pos ($ other 'position)))
($ player-coords (vector x y)) (match prev-pos
'push) (#(prev-x prev-y)
(_ #f))))))))))) (let ((offset (vector (- x prev-x) (- y prev-y))))
(define (warp-player x y) (pk 'collision! ($ obj 'type) ($ other 'type))
($ (grid-ref grid x y) player) ($ other 'collide obj offset grid-info)
(match ($ player-coords) ($ obj 'collide other offset grid-info)
(#f (maybe-update-grid other other-prev-pos ($ other 'position))
($ player-coords (vector x y))) (lp rest))))))))))))
(#(old-x old-y)
($ player-coords (vector x y))
($ (grid-ref grid old-x old-y) #f))))
(define (tick) (define (tick)
(define (neighbors x y) (define (neighbors x y)
(define (check x y) (define (check x y)
(match ($ (grid-ref/wrap grid x y)) (match ($ (grid-ref/wrap grid x y))
(#f 0) (() 0)
(refr ;; TODO: Handle tiles with many occupants.
((refr . _)
(match ($ refr 'wire-state) (match ($ refr 'wire-state)
('electron-head 1) ('electron-head 1)
(_ 0))))) (_ 0)))))
@ -153,6 +234,16 @@
(check x (+ y 1)) (check x (+ y 1))
(check (- x 1) (+ y 1)) (check (- x 1) (+ y 1))
(check (- x 1) y))) (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 (for-each (match-lambda
((refr . wire-state) ((refr . wire-state)
($ refr 'set-wire-state wire-state))) ($ refr 'set-wire-state wire-state)))
@ -162,9 +253,9 @@
(let x-loop ((x 0) (updates updates)) (let x-loop ((x 0) (updates updates))
(if (< x width) (if (< x width)
(match ($ (grid-ref grid x y)) (match ($ (grid-ref grid x y))
(#f (x-loop (1+ x) updates)) (() (x-loop (1+ x) updates))
(refr ;; TODO: Handle many occupants
($ refr 'tick) ((refr . _)
(match ($ refr 'wire-state) (match ($ refr 'wire-state)
(#f (x-loop (1+ x) updates)) (#f (x-loop (1+ x) updates))
('copper ('copper
@ -178,32 +269,13 @@
updates))) updates)))
updates)))) updates))))
;; Initialize grid cells
(for-each-coord
(lambda (x y)
(grid-set! grid x y (spawn ^cell))))
(match-lambda* (match-lambda*
(('tick) (tick))
(('describe) (('describe)
(let ((grid* (make-grid))) (map (lambda (obj) ($ obj 'describe)) ($ objects)))
(for-each-coord (('add-object obj)
(lambda (x y) ($ objects (cons obj ($ objects)))
(grid-set! grid* x y (match ($ obj 'position)
(match ($ (grid-ref grid x y)) (#(x y)
(#f #f) (let ((cell (grid-ref grid x y)))
(refr ($ refr 'describe)))))) ($ cell (cons obj ($ cell)))))))))
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)))

View file

@ -7,37 +7,39 @@
#:export (make-level #:export (make-level
level? level?
level-background level-background
level-actor)) level-actor
level-player))
;; Client-side rendering info coupled with level actor that contains ;; Client-side rendering info coupled with level actor that contains
;; game state. ;; game state.
(define-record-type <level> (define-record-type <level>
(%make-level background actor) (%make-level background actor player)
level? level?
(background level-background) (background level-background)
(actor level-actor)) (actor level-actor)
(player level-player))
(define (make-level width height background objects) (define (make-level width height background objects)
(let ((level* (spawn ^level width height))) (let ((level* (spawn ^level width height))
;; Parsed packed object data and spawn objects. (len (bytevector-length objects)))
(let ((len (bytevector-length objects))) ;; Parsed packed object data and spawn objects, making special
(let lp ((i 0)) ;; note of the player.
(when (< i len) (let lp ((i 0) (player #f))
(let ((x (bytevector-u8-ref objects i)) (if (< i len)
(let* ((x (bytevector-u8-ref objects i))
(y (bytevector-u8-ref objects (+ i 1))) (y (bytevector-u8-ref objects (+ i 1)))
(id (bytevector-u8-ref objects (+ i 2)))) (id (bytevector-u8-ref objects (+ i 2)))
(if (= id 3) ; player-spawn (obj (match id
(begin (1 (spawn ^wall x y 'brick))
(pk 'spawn-player x y) (2 (spawn ^wall x y 'copper))
($ level* 'warp-player x y)) (3 (spawn ^player x y))
(let ((obj (match id (4 (spawn ^exit x y))
(1 (spawn ^wall 'brick)) (5 (spawn ^block x y 'copper))
(2 (spawn ^wall 'copper)) (6 (spawn ^block x y 'crate))
(4 (spawn ^exit)) (7 (spawn ^clock-emitter x y 4))
(5 (spawn ^block 'copper))
(6 (spawn ^block 'crate))
(7 (spawn ^clock-emitter 4))
(id (error "invalid level object" id))))) (id (error "invalid level object" id)))))
($ level* 'set-object x y obj)))) ($ level* 'add-object obj)
(lp (+ i 3))))) (if (= id 3) ; player-spawn
(%make-level background level*))) (lp (+ i 3) obj)
(lp (+ i 3) player)))
(%make-level background level* player)))))

11
modules/local-storage.scm Normal file
View file

@ -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)