Add block pushing and wireworld simulation.

Makefile

@@ -6,6 +6,7 @@ modules = \
   modules/dom/image.scm \
   modules/dom/media.scm \
   modules/dom/window.scm \
+  modules/game/actors.scm \
   modules/math.scm \
   modules/math/rect.scm \
   modules/math/vector.scm

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

modules/game/actors.scm

@@ -0,0 +1,211 @@
+(define-module (game actors)
+  #:use-module (dom canvas)
+  #:use-module (goblins core)
+  #:use-module (ice-9 match)
+  #:export (^cell
+            ^level))
+
+;; ^wall
+;; ^wire
+;; ^electron-head
+;; ^electron-tail
+
+(define* (^cell bcom #:optional val)
+  (case-lambda
+    (() val)
+    ((new-val)
+     (bcom (^cell bcom new-val)))))
+
+(define (^wall bcom type)
+  (match-lambda*
+    (('tick) #f)
+    (('wire-state)
+     (match type
+       ((or 'copper 'electron-head 'electron-tail)
+        type)
+       (_ #f)))
+    (('set-wire-state type)
+     (bcom (^wall bcom type)))
+    (('describe) `(wall ,type))
+    (('collide) 'stop)))
+
+(define (^block bcom type)
+  (match-lambda*
+    (('tick) #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) 'displace)))
+
+(define (^clock-emitter bcom interval)
+  (define timer (spawn ^cell 0))
+  (match-lambda*
+    (('tick) ($ timer (+ ($ timer) 1)))
+    (('wire-state)
+     (let ((t ($ timer)))
+       (cond
+        ((= (modulo t interval) 0)
+         'electron-head)
+        ((= (modulo t interval) 1)
+         'electron-tail)
+        (else
+         'copper))))
+    (('set-wire-state type) #f)
+    (('describe) '(clock-emitter))
+    (('collide) 'stop)))
+
+(define (^player bcom)
+  (match-lambda*
+    (('tick) #f)
+    (('wire-state) #f)
+    (('describe) '(player))))
+
+(define (^level bcom width height)
+  (define player (spawn ^player))
+  (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 (for-each-coord proc)
+    (let y-loop ((y 0))
+      (when (< y height)
+        (let x-loop ((x 0))
+          (when (< x width)
+            (proc x y)
+            (x-loop (1+ x))))
+        (y-loop (1+ y)))))
+  (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)
+              ('stop #f)
+              ('displace
+               (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)))
+                   (_ #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 (tick)
+    (define (neighbors x y)
+      (define (check x y)
+        (match ($ (grid-ref/wrap grid x y))
+          (#f 0)
+          (refr
+           (match ($ refr 'wire-state)
+             ('electron-head 1)
+             (_ 0)))))
+      (+ (check (- x 1) (- y 1))
+         (check x (- y 1))
+         (check (+ x 1) (- y 1))
+         (check (+ x 1) y)
+         (check (+ x 1) (+ y 1))
+         (check x (+ y 1))
+         (check (- x 1) (+ y 1))
+         (check (- x 1) y)))
+    (for-each (match-lambda
+                ((refr . wire-state)
+                 ($ refr 'set-wire-state wire-state)))
+              (let y-loop ((y 0) (updates '()))
+                (if (< y height)
+                    (y-loop (1+ y)
+                            (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)
+                                     (match ($ refr 'wire-state)
+                                       (#f (x-loop (1+ x) updates))
+                                       ('copper
+                                        (if (<= 1 (neighbors x y) 2)
+                                            (x-loop (1+ x) (cons `(,refr . electron-head) updates))
+                                            (x-loop (1+ x) updates)))
+                                       ('electron-head
+                                        (x-loop (1+ x) (cons `(,refr . electron-tail) updates)))
+                                       ('electron-tail
+                                        (x-loop (1+ x) (cons `(,refr . copper) updates))))))
+                                  updates)))
+                    updates))))
+
+  ;; Initialize grid cells
+  (for-each-coord
+   (lambda (x y)
+     (grid-set! grid x y (spawn ^cell))))
+
+  ;; TODO: actually write levels
+  (warp-player 10 8)
+  ($ (grid-ref grid 4 4) (spawn ^wall 'brick))
+
+  ($ (grid-ref grid 4 3) (spawn ^clock-emitter 3))
+  ($ (grid-ref grid 5 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 6 4) (spawn ^block 'copper))
+  ($ (grid-ref grid 7 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 8 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 9 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 10 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 11 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 12 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 13 2) (spawn ^wall 'copper))
+  ($ (grid-ref grid 13 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 13 4) (spawn ^wall 'copper))
+  ($ (grid-ref grid 14 2) (spawn ^wall 'copper))
+  ($ (grid-ref grid 14 4) (spawn ^wall 'copper))
+  ($ (grid-ref grid 15 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 16 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 17 3) (spawn ^wall 'copper))
+  ($ (grid-ref grid 18 3) (spawn ^wall 'copper))
+
+  (match-lambda*
+    (('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*))
+    (('move-player dir)
+     (match dir
+       ('up (move-player 0 -1))
+       ('down (move-player 0 1))
+       ('left (move-player -1 0))
+       ('right (move-player 1 0)))
+     (tick))))

modules/goblins/core-types.scm

@@ -23,6 +23,7 @@
 (define-module (goblins core-types)
   #:use-module (hoot hashtables)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
   #:export (<actormap>
             _make-actormap
             actormap?
@@ -89,10 +90,6 @@
             live-refr?
             promise-refr?))
 
-;; hoot hacks
-
-(define *unspecified* (if #f #f))
-
 ;; Actormaps, etc
 ;; ==============
 (define-record-type <actormap>

modules/goblins/core.scm

@@ -102,24 +102,22 @@
             near-resolved-promise-value
 
             ;; test-core.scm needs these; they are not otherwise exported
-            *unspecified*
             transactormap-set!
             transactormap-ref
             mactor:local-link?)
-  #:pure
-  #:use-module ((hoot errors) #:select (raise-exception))
+  #:use-module (hoot bytevectors)
   #:use-module ((hoot error-handling) #:select (format-exception))
-  #:use-module (hoot exceptions)
+  #:use-module ((hoot exceptions) #:select (make-exception-with-irritants))
   #:use-module (hoot hashtables)
-  #:use-module (hoot match)
-  #:use-module ((hoot syntax) #:select (define*))
-  #:use-module (ice-9 control)
-  #:use-module (ice-9 vlist)
+  #:use-module ((hoot ports) #:select (flush-output-port))
+  #:use-module ((ice-9 control) #:select (call/ec))
+  #:use-module (ice-9 match)
   #:use-module (ice-9 q)
+  #:use-module (ice-9 vlist)
   #:use-module (goblins core-types)
   #:use-module (goblins ghash)
-  #:use-module (scheme base)
-  #:use-module (scheme write))
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11))
 
 
 ;;; Utilities (which should be moved to their own modules)
@@ -128,8 +126,6 @@
 ;;; hoot hacks
 
 
-(define *unspecified* (if #f #f))
-
 ;;; Here's basically your pre-goblins area.
 
 ;; mimic Racket's seteq
@@ -2110,7 +2106,8 @@ Type: Actormap (-> Any) (Optioan (#:reckless? Boolean)) -> Any"
   (display msg (current-error-port)) (newline (current-error-port))
   (display ";; exception: " (current-error-port))
   (format-exception err (current-error-port))
-  (newline (current-error-port)) (flush-output-port (current-error-port)))
+  (newline (current-error-port))
+  (flush-output-port (current-error-port)))
 
 (define (make-no-op msg)
   (lambda _ *unspecified*))

modules/goblins/ghash.scm

@@ -28,7 +28,7 @@
   #:use-module (hoot hashtables)
   #:use-module ((hoot lists) #:select (fold))
   #:use-module (ice-9 match)
-  #:use-module (scheme write)
+  #:use-module (srfi srfi-9)
   #:export (make-ghash
             ghash?
 

modules/guile/list.scm

@@ -22,7 +22,7 @@
 ;;; Code:
 
 (define-module (guile list)
-  #:export (delete delq delq! last-pair))
+  #:export (delete delq delq!))
 
 (define (fold proc acc lst)
   (if (null? lst)
@@ -34,11 +34,6 @@
 (define (fold-right proc acc lst)
   (fold proc acc (reverse lst)))
 
-(define (last-pair lst)
-  (if (null? (cdr lst))
-      lst
-      (last-pair (cdr lst))))
-
 (define (delete item lst . eq-pair)
   (define eq (if (pair? eq-pair) (car eq-pair) equal?))
   (fold-right (lambda (i acc)

modules/ice-9/control.scm

@@ -23,7 +23,6 @@
 ;;; Code:
 
 (define-module (ice-9 control)
-  #:use-module (hoot control)
   #:export (make-prompt-tag
             default-prompt-tag
             call-with-prompt

modules/ice-9/vlist.scm

@@ -44,9 +44,9 @@
 ;;; Code:
 
 (define-module (ice-9 vlist)
-  #:use-module (hoot fluids)
   #:use-module (hoot hashtables)
   #:use-module ((hoot lists) #:select (fold))
+  #:use-module (srfi srfi-9)
   #:export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
                    vlist-null list->vlist vlist-ref vlist-drop vlist-take
                    vlist-length vlist-fold vlist-fold-right vlist-map
@@ -65,8 +65,6 @@
   ;;; Hoot Hacks™ (not really ™)
 
 ;; XXX hashes using equal? and eqv? have not been defined; use only eq?
-(define equal? eq?)
-(define eqv? eq?)
 (define hash hashq)
 (define hashv hashq)
 (define (fold-right proc init lst)

modules/srfi/srfi-11.scm

@@ -0,0 +1,3 @@
+(define-module (srfi srfi-11)
+  #:use-module ((hoot syntax) #:select (let-values let*-values))
+  #:re-export (let-values let*-values))

modules/srfi/srfi-9.scm

@@ -0,0 +1,3 @@
+(define-module (srfi srfi-9)
+  #:use-module ((scheme base) #:select (define-record-type))
+  #:re-export (define-record-type))