Add block pushing and wireworld simulation.

game.scm

@@ -25,6 +25,8 @@
              (dom image)
              (dom media)
              (dom window)
+             (game actors)
+             (goblins core)
              (hoot ffi)
              (hoot hashtables)
              (ice-9 match)
@@ -36,16 +38,57 @@
 (define game-height 240.0)
 (define tile-width 16.0)
 (define tile-height 16.0)
+(define level-width (inexact->exact (floor (/ game-width tile-width))))
+(define level-height (inexact->exact (floor (/ game-height tile-height))))
+
+(define *canvas-scale* 0.0)
+(define *canvas-width* 0)
+(define *canvas-height* 0)
 
 (define image:tiles (make-image "assets/images/cirkoban.png"))
 
+;; Game state
+(define *actormap* (make-whactormap))
+(define (call-with-goblins thunk)
+  (actormap-churn-run! *actormap* thunk))
+(define-syntax-rule (with-goblins body ...)
+  (call-with-goblins (lambda () body ...)))
+
+(define *level* #f)
+;; Latest representation of all actors in level
+(define *grid* #f)
+
+(define *snapshots* '())
+(define (clear-snapshots!)
+  (set! *snapshots* '()))
+(define (save-snapshot!)
+  (set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))
+
+(define (update-grid!)
+  (set! *grid* ($ *level* 'describe)))
+
+(define (reset-game!)
+  (set! *actormap* (make-whactormap))
+  (clear-snapshots!)
+  (with-goblins
+   (set! *level* (spawn ^level level-width level-height))
+   (update-grid!)))
+
+;; Update loop
+(define (move-player dir)
+  (with-goblins
+   ($ *level* 'move-player dir)
+   (update-grid!))
+  ;; (save-snapshot!)
+  )
+
 (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
 (define (update)
-  #t
+  ;; TODO: what kind of work do we need to do each frame?
   (timeout update-callback dt))
 (define update-callback (procedure->external update))
 
-;; Rendering
+;; Render loop
 (define number->string*
   (let ((cache (make-eq-hashtable))) ; assuming fixnums only
     (lambda (x)
@@ -54,27 +97,98 @@
             (hashtable-set! cache x str)
             str)))))
 
-(define (draw prev-time)
-  (set-fill-color! context "#140c1c")
-  (fill-rect context 0.0 0.0 game-width game-height)
-  (set-fill-color! context "#ffffff")
-  (set-font! context "bold 24px monospace")
-  (set-text-align! context "left")
-  (fill-text context "HELLO" 16.0 36.0)
+(define (draw-player x y)
   (draw-image context image:tiles
               0.0 0.0 tile-width tile-height
-              100.0 100.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
+                 32.0 16.0 tile-width tile-height
+                 (* x tile-width) (* y tile-height) tile-width tile-height))
+    (_
+     (draw-image context image:tiles
+                 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
+                 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
+                 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
+              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
+                 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
+                 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
+              48.0 0.0 tile-width tile-height
+              (* x tile-width) (* y tile-height) tile-width tile-height))
+
+(define (draw-tile x y obj)
+  (match obj
+    (#f #f)
+    (('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*))
+    (let y-loop ((y 0))
+      (when (< y level-height)
+        (let x-loop ((x 0))
+          (when (< x level-width)
+            (draw-tile x y (vector-ref grid (+ (* y level-width) x)))
+            (x-loop (1+ x))))
+        (y-loop (1+ y))))))
+
+(define (draw prev-time)
+  (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
+  (set-fill-color! context "#cbdbfc")
+  (fill-rect context 0.0 0.0 *canvas-width* *canvas-height*)
+  (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
+  (set-scale! context *canvas-scale* *canvas-scale*)
+  (draw-level)
   (request-animation-frame draw-callback))
 (define draw-callback (procedure->external draw))
 
 ;; Input
 (define key:left "ArrowLeft")
 (define key:right "ArrowRight")
+(define key:down "ArrowDown")
+(define key:up "ArrowUp")
 (define key:confirm "Enter")
 
 (define (on-key-down event)
   (let ((key (keyboard-event-code event)))
-    (pk 'key-down key)))
+    (cond
+     ((string=? key key:left)
+      (move-player 'left))
+     ((string=? key key:right)
+      (move-player 'right))
+     ((string=? key key:up)
+      (move-player 'up))
+     ((string=? key key:down)
+      (move-player 'down)))))
 
 (define (on-key-up event)
   (let ((key (keyboard-event-code event)))
@@ -83,11 +197,33 @@
 ;; Canvas and event loop setup
 (define canvas (get-element-by-id "canvas"))
 (define context (get-context canvas "2d"))
+
+(define (resize-canvas)
+  (let* ((win (current-window))
+         (w (window-inner-width win))
+         (h (window-inner-height win))
+         (gw (inexact->exact game-width))
+         (gh (inexact->exact game-height))
+         (scale (max (min (quotient w gw) (quotient h gh)) 1))
+         (cw (* gw scale))
+         (ch (* gh scale)))
+    (set-element-width! canvas cw)
+    (set-element-height! canvas ch)
+    (set-image-smoothing-enabled! context 0)
+    (set! *canvas-scale* (exact->inexact scale))
+    (set! *canvas-width* (* game-width *canvas-scale*))
+    (set! *canvas-height* (* game-height *canvas-scale*))
+    (pk 'resize-canvas *canvas-scale* *canvas-width* *canvas-height*)))
+
 (set-element-width! canvas (inexact->exact game-width))
 (set-element-height! canvas (inexact->exact game-height))
+(add-event-listener! (current-window) "resize"
+                     (procedure->external (lambda (_) (resize-canvas))))
 (add-event-listener! (current-document) "keydown"
                      (procedure->external on-key-down))
 (add-event-listener! (current-document) "keyup"
                      (procedure->external on-key-up))
+(resize-canvas)
 (request-animation-frame draw-callback)
 (timeout update-callback dt)
+(reset-game!)