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

2024-05-20 22:12:35 -04:00 · 2024-05-20 22:12:35 -04:00 · 816d9d149d
commit 816d9d149d
parent ce0c002e8b
7 changed files with 321 additions and 202 deletions
--- a/.gitignore
+++ b/.gitignore
@ -1,2 +1,3 @@
 /game.wasm
 /modules/game/levels/*.scm
+/cirkoban.zip
--- a/5
+++ b/5
@ -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
--- 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(),
--- 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!)
--- 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)))))))))
--- 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 <level>
-  (%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)))))
--- a/modules/local-storage.scm
+++ 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)