Add basic undo with Z key.

Makefile

@@ -7,9 +7,20 @@ modules = \
   modules/dom/media.scm \
   modules/dom/window.scm \
   modules/game/actors.scm \
+  modules/game/tileset.scm \
+  modules/goblins/abstract-types.scm \
+  modules/goblins/core.scm \
+  modules/goblins/core-types.scm \
+  modules/goblins/ghash.scm \
+  modules/guile/list.scm \
+  modules/ice-9/control.scm \
+  modules/ice-9/q.scm \
+  modules/ice-9/vlist.scm \
   modules/math.scm \
   modules/math/rect.scm \
-  modules/math/vector.scm
+  modules/math/vector.scm \
+  modules/srfi/srfi-9.scm \
+  modules/srfi/srfi-11.scm
 
 game.wasm: game.scm $(modules)
 	guild compile-wasm -L modules -o $@ $<
@@ -19,7 +30,7 @@ serve: game.wasm
 
 bundle: game.wasm
 	rm game.zip || true
-	zip game.zip -r assets/ js-runtime/ game.js game.css game.wasm index.html
+	zip game.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.scm

@@ -26,6 +26,7 @@
              (dom media)
              (dom window)
              (game actors)
+             (game tileset)
              (goblins core)
              (hoot ffi)
              (hoot hashtables)
@@ -45,7 +46,11 @@
 (define *canvas-width* 0)
 (define *canvas-height* 0)
 
-(define image:tiles (make-image "assets/images/cirkoban.png"))
+(define tileset
+  (make-tileset (make-image "assets/images/cirkoban.png")
+                320 240
+                (inexact->exact tile-width)
+                (inexact->exact tile-height)))
 
 ;; Game state
 (define *actormap* (make-whactormap))
@@ -63,6 +68,12 @@
   (set! *snapshots* '()))
 (define (save-snapshot!)
   (set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))
+(define (rollback-snapshot!)
+  (match *snapshots*
+    (() #f)
+    ((snapshot . older-snapshots)
+     (set! *actormap* snapshot)
+     (set! *snapshots* older-snapshots))))
 
 (define (update-grid!)
   (set! *grid* ($ *level* 'describe)))
@@ -76,11 +87,10 @@
 
 ;; Update loop
 (define (move-player dir)
+  (save-snapshot!)
   (with-goblins
    ($ *level* 'move-player dir)
-   (update-grid!))
+   (update-grid!)))
-  ;; (save-snapshot!)
-  )
 
 (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
 (define (update)
@@ -98,58 +108,43 @@
             str)))))
 
 (define (draw-player x y)
-  (draw-image context image:tiles
+  (draw-tile context tileset 0 x y))
-              0.0 0.0 tile-width tile-height
-              (* x tile-width) (* y tile-height) tile-width tile-height))
 
 (define (draw-wall type x y)
   (match type
     ('brick
-     (draw-image context image:tiles
+     (draw-tile context tileset 22 x y))
-                 32.0 16.0 tile-width tile-height
-                 (* x tile-width) (* y tile-height) tile-width tile-height))
     (_
-     (draw-image context image:tiles
+     (draw-tile context tileset 2 x y)))
-                 48.0 0.0 tile-width tile-height
-                 (* x tile-width) (* y tile-height) tile-width tile-height)))
   (match type
     ('electron-head
-     (draw-image context image:tiles
+     (draw-tile context tileset 4 x y))
-                 64.0 0.0 tile-width tile-height
-                 (* x tile-width) (* y tile-height) tile-width tile-height))
     ('electron-tail
-     (draw-image context image:tiles
+     (draw-tile context tileset 5 x y))
-                 80.0 0.0 tile-width tile-height
-                 (* x tile-width) (* y tile-height) tile-width tile-height))
     (_ #f)))
 
 (define (draw-block type x y)
-  (draw-image context image:tiles
+  (draw-tile context tileset 3 x y)
-              32.0 0.0 tile-width tile-height
-              (* x tile-width) (* y tile-height) tile-width tile-height)
   (match type
     ('electron-head
-     (draw-image context image:tiles
+     (draw-tile context tileset 4 x y))
-                 64.0 0.0 tile-width tile-height
-                 (* x tile-width) (* y tile-height) tile-width tile-height))
     ('electron-tail
-     (draw-image context image:tiles
+     (draw-tile context tileset 5 x y))
-                 80.0 0.0 tile-width tile-height
-                 (* x tile-width) (* y tile-height) tile-width tile-height))
     (_ #f)))
 
 (define (draw-clock-emitter x y)
-  (draw-image context image:tiles
+  (draw-tile context tileset 2 x y))
-              48.0 0.0 tile-width tile-height
-              (* x tile-width) (* y tile-height) tile-width tile-height))
 
-(define (draw-tile x y obj)
+(define (draw-object x y obj)
-  (match obj
+  (and obj
-    (#f #f)
+       (let ((x (* x tile-width))
-    (('player) (draw-player x y))
+             (y (* y tile-height)))
-    (('wall type) (draw-wall type x y))
+         (match obj
-    (('block type) (draw-block type x y))
+           (#f #f)
-    (('clock-emitter) (draw-clock-emitter x y))))
+           (('player) (draw-player 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-level)
   (let ((grid *grid*))
@@ -157,7 +152,7 @@
       (when (< y level-height)
         (let x-loop ((x 0))
           (when (< x level-width)
-            (draw-tile x y (vector-ref grid (+ (* y level-width) x)))
+            (draw-object x y (vector-ref grid (+ (* y level-width) x)))
             (x-loop (1+ x))))
         (y-loop (1+ y))))))
 
@@ -177,6 +172,7 @@
 (define key:down "ArrowDown")
 (define key:up "ArrowUp")
 (define key:confirm "Enter")
+(define key:undo "KeyZ")
 
 (define (on-key-down event)
   (let ((key (keyboard-event-code event)))
@@ -188,7 +184,10 @@
      ((string=? key key:up)
       (move-player 'up))
      ((string=? key key:down)
-      (move-player 'down)))))
+      (move-player 'down))
+     ((string=? key key:undo)
+      (rollback-snapshot!)
+      (with-goblins (update-grid!))))))
 
 (define (on-key-up event)
   (let ((key (keyboard-event-code event)))

modules/game/tileset.scm

@@ -0,0 +1,47 @@
+(define-module (game tileset)
+  #:use-module (dom canvas)
+  #:use-module (dom image)
+  #:use-module (ice-9 match)
+  #:use-module (math rect)
+  #:use-module (srfi srfi-9)
+  #:export (make-tileset
+            tileset?
+            tileset-image
+            tileset-tile-width
+            tileset-tile-height
+            draw-tile))
+
+(define-record-type <tileset>
+  (%make-tileset image tile-width tile-height tiles)
+  tileset?
+  (image tileset-image)
+  (tile-width tileset-tile-width)
+  (tile-height tileset-tile-height)
+  (tiles tileset-tiles))
+
+(define (make-tileset image width height tile-width tile-height)
+  (let* ((w (quotient width tile-width))
+         (h (quotient height tile-height))
+         (tiles (make-vector (* w h))))
+    (let y-loop ((y 0))
+      (when (< y h)
+        (let x-loop ((x 0))
+          (when (< x w)
+            (vector-set! tiles (+ (* y w) x)
+                         (make-rect (* x tile-width)
+                                    (* y tile-height)
+                                    tile-width
+                                    tile-height))
+            (x-loop (1+ x))))
+        (y-loop (1+ y))))
+    (%make-tileset image tile-width tile-height tiles)))
+
+(define (draw-tile context tileset idx x y)
+  (match tileset
+    (($ <tileset> image _ _ tiles)
+     (let* ((tile (vector-ref tiles idx))
+            (sx (rect-x tile))
+            (sy (rect-y tile))
+            (w (rect-width tile))
+            (h (rect-height tile)))
+       (draw-image context image sx sy w h x y w h)))))