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

.gitignore

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

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
+	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:
 	rm -f game.wasm game.zip

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(),

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!)
+(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! *actormap* (make-whactormap))
   (clear-snapshots!)
-  (set! *level-idx* -1)
   (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
 (define (move-player dir)
-  (save-snapshot!)
+  (define (do-move)
     (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)
-      (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 (update)
@@ -147,13 +183,15 @@
             (hashtable-set! cache x 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
       ('brick
        (draw-tile context tileset 22 x y))
@@ -164,33 +202,32 @@
        (draw-tile context tileset 4 x y))
       ('electron-tail
        (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
       ('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
       ('electron-head
        (draw-tile context tileset 4 x y))
       ('electron-tail
        (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
     (#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)
   (let* ((bv (level-background *level*))
@@ -205,14 +242,7 @@
 
 (define (draw-level)
   (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)
   (set-fill-color! context "#x000000")
@@ -252,9 +282,7 @@
          (move-player 'down))
         ((string=? key key:undo)
          (rollback-snapshot!)
-         (with-goblins (update-grid!)))
+         (with-goblins (update-objects!)))))
-        ((string=? key key:confirm)
-         (reset-game!))))
       ('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!)

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))
+    (('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*
+    (('type) 'wall)
+    (('position) position)
     (('tick) #f)
     (('wire-state)
      (match type
@@ -32,26 +43,47 @@
         type)
        (_ #f)))
     (('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*
-    (('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)))
+     (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 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))
+    (('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*
-    (('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))
+  (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)
     (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 (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 (neighbors x y)
       (define (check x y)
         (match ($ (grid-ref/wrap grid x y))
-          (#f 0)
+          (() 0)
-          (refr
+          ;; 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))
+                                    (() (x-loop (1+ x) updates))
-                                    (refr
+                                    ;; TODO: Handle many occupants
-                                     ($ refr 'tick)
+                                    ((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)))
+     (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)))

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)))
+  (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)))
-                (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)))))
-                  ($ 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)))))

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)