foss-mmo/modules/game/actors.scm

;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;; Copyright (C) 2024 Juliana Sims <juli@incana.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (game actors)
  #:use-module (goblins core)
  #:use-module (ice-9 match)
  #:export (^cell
            ^exit
            ^wall
            ^block
            ^clock-emitter
            ^switched-emitter
            ^floor-switch
            ^gate
            ^bomb
            ^brick
            ^gem
            ^and-gate
            ^xor-gate
            ^or-gate
            ^electric-switch
            ^electron-warp
            ^player
            ^level))

;; The default wireworld rules.  Actors are free to use this or
;; implement their own rule for themselves.
(define (wireworld-next wire-state neighbors)
  (match wire-state
    (#f #f)
    ('copper (if (<= 1 neighbors 2) 'electron-head 'copper))
    ('electron-head 'electron-tail)
    ('electron-tail 'copper)))

(define (electron-head-count neighbor-grid)
  (define (check state)
    (match state
      ('electron-head 1)
      (_ 0)))
  (match neighbor-grid
    (#(a b c d '_ e f g h)
     (+ (check a)
        (check b)
        (check c)
        (check d)
        (check e)
        (check f)
        (check g)
        (check h)))))

(define* (^cell bcom #:optional val)
  (case-lambda
    (() val)
    ((new-val)
     (bcom (^cell bcom new-val)))))

;; TODO: Port actor-lib methods and use it.
(define (^exit bcom x y)
  (define position (vector x y 1))
  (match-lambda*
    (('type) 'exit)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y) #f)
    (('update-wire-state grid-info neighbor-grid) #f)
    (('alive?) #t)
    (('describe) `(exit ,position))
    (('collide other offset grid-info) #f)))

;; TODO: Maybe make separate actors for conductive vs. inert walls.
(define (^wall bcom x y type)
  (define position (vector x y 1))
  (match-lambda*
    (('type) 'wall)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('update-wire-state grid-info neighbor-grid)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        (let* ((neighbors (electron-head-count neighbor-grid))
               (type (wireworld-next type neighbors)))
          (bcom (^wall bcom x y type))))
       (_ #f)))
    (('alive?) #t)
    (('describe) `(wall ,position ,type))
    (('collide other offset grid-info) #f)))

(define (^brick bcom x y)
  (define position (vector x y 1))
  (define alive? (spawn ^cell #t))
  (match-lambda*
    (('type) 'brick)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y) #f)
    (('update-wire-state grid-info neighbor-grid) #f)
    (('alive?) ($ alive?))
    (('explode) ($ alive? #f))
    (('describe) `(brick ,position))
    (('collide other offset grid-info) #f)))

;; TODO: Maybe make separate actors for conductive vs. inert blocks.
(define (^block bcom x y type)
  (define position (spawn ^cell (vector x y 1)))
  (define pushed? (spawn ^cell))
  (match-lambda*
    (('type) 'block)
    (('position) ($ position))
    (('tick grid-info) ($ pushed? #f))
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('activate grid-info) #f)
    (('deactivate grid-info) #f)
    (('wire-state grid-info from from-x from-y)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('update-wire-state grid-info neighbor-grid)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        (match ($ position)
          (#(x y z)
           (let* ((neighbors (electron-head-count neighbor-grid))
                  (type (wireworld-next type neighbors)))
             (bcom (^block bcom x y type))))))
       (_ #f)))
    (('alive?) #t)
    (('describe) `(block ,($ position) ,type))
    (('collide other offset grid-info)
     (when (eq? ($ other 'type) 'player)
       (match ($ position)
         (#(x y z)
          (match offset
            (#(dx dy)
             (match ($ grid-info 'dimensions)
               (#(w h)
                (let ((x (modulo (+ x dx) w))
                      (y (modulo (+ y dy) h)))
                  (define (do-push)
                    ($ pushed? #t)
                    ($ position (vector x y z)))
                  (match ($ grid-info 'occupants x y)
                    (() (do-push))
                    ((obj)
                     (match ($ obj 'type)
                       ('switch (do-push))
                       ('gate (when ($ obj 'open?) (do-push)))
                       (_ #f)))
                    (_ #f)))))))))))
    (('pushed?) ($ pushed?))))

(define (^clock-emitter bcom x y interval)
  (define timer (spawn ^cell 0))
  (define position (vector x y 0))
  (define (wire-state)
    (match ($ timer)
      (0 'electron-head)
      (1 'electron-tail)
      (_ 'copper)))
  (match-lambda*
    (('type) 'emitter)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info)
     (let ((t (modulo (+ ($ timer) 1) interval)))
       ($ timer t)
       (when (= t 1)
         ($ grid-info 'append-event `(emit ,x ,y)))))
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y) (wire-state))
    (('update-wire-state grid-info neighbor-grid) #f)
    (('alive?) #t)
    (('describe) `(clock-emitter ,position ,(wire-state)))
    (('collide other offset grid-info) #f)))

(define (^switched-emitter bcom x y interval)
  (define timer (spawn ^cell 0))
  (define on? (spawn ^cell))
  (define position (vector x y 0))
  (define activations (spawn ^cell 0))
  (define (wire-state)
    (and ($ on?)
         (match ($ timer)
           (0 'electron-head)
           (1 'electron-tail)
           (_ 'copper))))
  (match-lambda*
    (('type) 'switched-emitter)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info)
     (when ($ on?)
       (let ((t (modulo (+ ($ timer) 1) interval)))
         ($ timer t)
         (when (= t 1)
           ($ grid-info 'append-event `(emit ,x ,y))))))
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('activate grid-info)
     (let ((k (1+ ($ activations))))
       ($ activations k)
       (unless (> k 1)
         ($ on? #t)
         ($ timer 0)
         ($ grid-info 'append-event `(emitter-on ,x ,y)))))
    (('deactivate grid-info)
     (let ((k (1- ($ activations))))
       ($ activations k)
       (when (= k 0)
         ($ on? #f)
         ($ grid-info 'append-event `(emitter-off ,x ,y)))))
    (('wire-state grid-info from from-x from-y) (wire-state))
    (('update-wire-state grid-info neighbor-grid) #f)
    (('alive?) #t)
    (('on?) ($ on?))
    (('describe) `(switched-emitter ,position ,(wire-state)))
    (('collide other offset grid-info) #f)))

(define (non-player-occupants grid-info x y)
  (let lp ((objs ($ grid-info 'occupants x y)))
    (match objs
      (() '())
      ((obj . rest)
       (if (eq? ($ obj 'type) 'player)
           (lp rest)
           (cons obj (lp rest)))))))

(define (^floor-switch bcom x y target-x target-y)
  (define position (vector x y 0))
  (define on? (spawn ^cell))
  (match-lambda*
    (('type) 'switch)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info)
     ($ on? #t))
    (('exit obj grid-info)
     (when (= (length ($ grid-info 'occupants x y)) 1)
       ($ on? #f)
       (for-each (lambda (obj)
                   ($ grid-info 'append-event `(floor-switch-off ,x ,y))
                   ($ obj 'deactivate grid-info))
                 (non-player-occupants grid-info target-x target-y))))
    (('wire-state grid-info from from-x from-y) #f)
    (('update-wire-state grid-info neighbor-grid) #f)
    (('alive?) #t)
    (('describe) `(floor-switch ,position ,($ on?)))
    (('collide other offset grid-info)
     ($ on? #t)
     (for-each (lambda (obj)
                 ($ grid-info 'append-event `(floor-switch-on ,x ,y))
                 ($ obj 'activate grid-info))
               (non-player-occupants grid-info target-x target-y)))))

(define (^electric-switch bcom x y target-x target-y)
  (define position (vector x y 0))
  (define on? (spawn ^cell))
  (define timer (spawn ^cell))
  (match-lambda*
    (('type) 'electric-switch)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y) #f)
    (('update-wire-state grid-info neighbor-grid)
     (if ($ on?)
         (let ((t (1- ($ timer))))
           ($ timer t)
           (when (= t 0)
             ($ on? #f)
             (for-each (lambda (obj)
                         ($ grid-info 'append-event `(electic-switch-off ,x ,y))
                         ($ obj 'deactivate grid-info))
                       (non-player-occupants grid-info target-x target-y))))
         (when (>= (electron-head-count neighbor-grid) 1)
           ($ on? #t)
           ($ timer 2)
           (for-each (lambda (obj)
                       ($ grid-info 'append-event `(electic-switch-on ,x ,y))
                       ($ obj 'activate grid-info))
                     (non-player-occupants grid-info target-x target-y)))))
    (('alive?) #t)
    (('describe) `(electric-switch ,position ,($ on?)))
    (('collide other offset grid-info) #f)))

(define (^electron-warp bcom x y target-x target-y)
  (define position (vector x y 0))
  (define state (spawn ^cell 'copper))
  (define warp-state (spawn ^cell 'waiting))
  (define (find-receiver grid-info)
    (let lp ((objs ($ grid-info 'occupants target-x target-y)))
      (match objs
        (() (error "no electron receiver at tile" target-x target-y))
        ((obj . rest)
         (if (eq? ($ obj 'type) 'electron-warp)
             obj
             (lp rest))))))
  (match-lambda*
    (('type) 'electron-warp)
    (('position) position)
    (('tick grid-info)
     (when (eq? ($ warp-state) 'receiving)
       ($ warp-state 'received)))
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y) ($ state))
    (('update-wire-state grid-info neighbor-grid)
     (match ($ state)
       ('electron-head ($ state 'electron-tail))
       ('electron-tail ($ state 'copper))
       ('copper
        (if (eq? ($ warp-state) 'received)
            (begin
              ($ state 'electron-head)
              ($ warp-state 'waiting)
              ($ grid-info 'append-event `(receive-electron ,x ,y)))
            (let ((neighbors (electron-head-count neighbor-grid)))
              (if (<= 1 neighbors 2)
                  (begin
                    ($ state 'electron-head)
                    ;; Forward an electron head to the receiver.
                    ($ (find-receiver grid-info) 'give-electron)
                    ($ grid-info 'append-event `(send-electron ,x ,y)))
                  ($ state 'copper)))))))
    (('give-electron) ($ warp-state 'receiving))
    (('alive?) #t)
    (('describe) `(electron-warp ,position ,($ state)))
    (('collide other offset grid-info) #f)))

(define (^bomb bcom x y)
  (define position (spawn ^cell (vector x y 1)))
  (define alive? (spawn ^cell #t))
  (define countdown (spawn ^cell -1))
  (define pushed? (spawn ^cell))
  (define (light-fuse)
    ($ countdown 2))
  (match-lambda*
    (('type) 'bomb)
    (('position) ($ position))
    (('tick grid-info)
     ($ pushed? #f)
     (when (> ($ countdown) 0)
       (let ((cd (1- ($ countdown))))
         ($ countdown cd)
         (when (= cd 0)
           ($ alive? #f)
           (match ($ position)
             (#(x y z)
              (do ((ix (- x 1) (+ ix 1)))
                  ((> ix (+ x 1)))
                (do ((iy (- y 1) (+ iy 1)))
                    ((> iy (+ y 1)))
                  (unless (and (= ix x) (= iy y))
                    (let ((obj (match ($ grid-info 'occupants ix iy)
                                 (() #f)
                                 ((obj . rest) obj))))
                      (when obj
                        (match ($ obj 'type)
                          ((or 'bomb 'brick)
                           ($ obj 'explode))
                          ('player
                           ($ obj 'explode)
                           ($ grid-info 'append-event `(player-death ,ix ,iy)))
                          (_ #f)))))))
              ($ grid-info 'append-event `(explosion ,x ,y))))))))
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y) #f)
    (('update-wire-state grid-info neighbor-grid)
     (when (and (< ($ countdown) 0)
                (> (electron-head-count neighbor-grid) 0))
       (light-fuse)))
    (('alive?) ($ alive?))
    (('describe) `(bomb ,($ position) ,($ countdown)))
    (('explode) (light-fuse))
    (('activate grid-info) #f)
    (('deactivate grid-info) #f)
    (('collide other offset grid-info)
     (when (eq? ($ other 'type) 'player)
       (match ($ position)
         (#(x y z)
          (match offset
            (#(dx dy)
             (match ($ grid-info 'dimensions)
               (#(w h)
                (let ((x (modulo (+ x dx) w))
                      (y (modulo (+ y dy) h)))
                  (let ((occupant-types
                         (map (lambda (obj) ($ obj 'type))
                              ($ grid-info 'occupants x y))))
                    (match occupant-types
                      ((or () ('switch))
                       ($ pushed? #t)
                       ($ position (vector x y z)))
                      (_ #f))))))))))))
    (('pushed?) ($ pushed?))))

;; A gem that has already been collected previously will still appear
;; in the level but it will be drawn differently.
(define* (^gem bcom x y previously-collected? #:optional test?)
  (define position (vector x y 1))
  (define picked-up? (spawn ^cell))
  (match-lambda*
    (('type) 'gem)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y) #f)
    (('update-wire-state grid-info neighbor-grid) #f)
    (('alive?) (not ($ picked-up?)))
    (('previously-collected?) previously-collected?)
    (('describe)
     (if previously-collected?
         `(ghost-gem ,position)
         `(gem ,position)))
    (('collide other offset grid-info)
     (when (eq? ($ other 'type) 'player)
       ($ picked-up? #t)
       ($ grid-info 'append-event `(pickup ,x ,y))))))

(define (^gate bcom x y)
  (define position (vector x y 1))
  (define open? (spawn ^cell))
  (define activations (spawn ^cell 0))
  (match-lambda*
    (('type) 'gate)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('activate grid-info)
     (let ((k (1+ ($ activations))))
       ($ activations k)
       (unless (> k 1)
         ($ open? #t)
         ($ grid-info 'append-event `(gate-open ,x ,y)))))
    (('deactivate grid-info)
     (let ((k (1- ($ activations))))
       ($ activations k)
       (when (= k 0)
         ($ open? #f)
         ($ grid-info 'append-event `(gate-close ,x ,y)))))
    (('wire-state grid-info from from-x from-y) #f)
    (('update-wire-state grid-info neighbor-grid) #f)
    (('alive?) #t)
    (('open?) ($ open?))
    (('describe) `(gate ,position ,($ open?)))
    (('collide other offset grid-info) #f)))

(define (^logic-gate bcom x y name direction update-wire-state)
  (define position (vector x y 0))
  (define state (spawn ^cell 'copper))
  (match-lambda*
    (('type) 'emitter)
    (('position) position)
    (('tick grid-info) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y)
     ;; We are compressing what would take many cells in the actual
     ;; Wireworld into a single tile.  A naive approach to this would
     ;; send electrons flowing backwards through the logic gates. So,
     ;; need to play a trick to make enforce directionality.  The
     ;; trick is that we know who is asking for our wire state.  If
     ;; the object is opposes the direction we are pushing electrons,
     ;; then we tell them we're just copper.  Otherwise, we reveal our
     ;; true state.  Sneaky, sneaky.
     (match direction
       ('left (if (> from-x x) 'copper ($ state)))
       ('right (if (< from-x x) 'copper ($ state)))
       ('up (if (> from-y y) 'copper ($ state)))
       ('down (if (< from-y y) 'copper ($ state)))))
    (('update-wire-state grid-info neighbor-grid)
     (match ($ state)
       ('electron-head ($ state 'electron-tail))
       ('electron-tail ($ state 'copper))
       ('copper
        (update-wire-state state neighbor-grid))))
    (('alive?) #t)
    (('describe) `(,name ,position ,direction ,($ state)))
    (('collide other offset grid-info) #f)))

(define (^and-gate bcom x y direction)
  (define (update-wire-state state neighbor-grid)
    (match direction
      ('right
       (match neighbor-grid
         (#('electron-head #f #f
                           #f _ 'copper
                           'electron-head #f #f)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('left
       (match neighbor-grid
         (#(#f #f 'electron-head
               'copper _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('up
       (match neighbor-grid
         (#(#f 'copper #f
               #f _ #f
               'electron-head #f 'electron-head)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('down
       (match neighbor-grid
         (#('electron-head #f 'electron-head
                           #f _ #f
                           #f 'copper #f)
          ($ state 'electron-head))
         (_ ($ state 'copper))))))
  (^logic-gate bcom x y 'and-gate direction update-wire-state))

(define (^xor-gate bcom x y direction)
  (define (update-wire-state state neighbor-grid)
    (match direction
      ('right
       (match neighbor-grid
         (#('electron-head #f #f
                           #f _ 'copper
                           #f #f #f)
          ($ state 'electron-head))
         (#('electron-head #f #f
                           #f _ 'copper
                           'copper #f #f)
          ($ state 'electron-head))
         (#(#f #f #f
               #f _ 'copper
               'electron-head #f #f)
          ($ state 'electron-head))
         (#('copper #f #f
                    #f _ 'copper
                    'electron-head #f #f)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('left
       (match neighbor-grid
         (#(#f #f 'electron-head
               'copper _ #f
               #f #f #f)
          ($ state 'electron-head))
         (#(#f #f 'electron-head
               'copper _ #f
               #f #f 'copper)
          ($ state 'electron-head))
         (#(#f #f #f
               'copper _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (#(#f #f 'copper
               'copper _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('up
       (match neighbor-grid
         (#(#f 'copper #f
               #f _ #f
               'electron-head #f #f)
          ($ state 'electron-head))
         (#(#f 'copper #f
               #f _ #f
               'electron-head #f 'copper)
          ($ state 'electron-head))
         (#(#f 'copper #f
               #f _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (#(#f 'copper #f
               #f _ #f
               'copper #f 'electron-head)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('down
       (match neighbor-grid
         (#('electron-head #f #f
                           #f _ #f
                           #f 'copper #f)
          ($ state 'electron-head))
         (#('electron-head #f 'copper
                           #f _ #f
                           #f 'copper #f)
          ($ state 'electron-head))
         (#(#f #f 'electron-head
               #f _ #f
               #f 'copper #f)
          ($ state 'electron-head))
         (#('copper #f 'electron-head
                    #f _ #f
                    #f 'copper #f)
          ($ state 'electron-head))
         (_ ($ state 'copper))))))
  (^logic-gate bcom x y 'xor-gate direction update-wire-state))

(define (^or-gate bcom x y direction)
  (define (update-wire-state state neighbor-grid)
    (match direction
      ('right
       (match neighbor-grid
         (#('electron-head #f #f
                           #f _ 'copper
                           #f #f #f)
          ($ state 'electron-head))
         (#('electron-head #f #f
                           #f _ 'copper
                           'copper #f #f)
          ($ state 'electron-head))
         (#(#f #f #f
               #f _ 'copper
               'electron-head #f #f)
          ($ state 'electron-head))
         (#('copper #f #f
                    #f _ 'copper
                    'electron-head #f #f)
          ($ state 'electron-head))
         (#('electron-head #f #f
                           #f _ 'copper
                           'electron-head #f #f)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('left
       (match neighbor-grid
         (#(#f #f 'electron-head
               'copper _ #f
               #f #f #f)
          ($ state 'electron-head))
         (#(#f #f 'electron-head
               'copper _ #f
               #f #f 'copper)
          ($ state 'electron-head))
         (#(#f #f #f
               'copper _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (#(#f #f 'copper
               'copper _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (#(#f #f 'electron-head
               'copper _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('up
       (match neighbor-grid
         (#(#f 'copper #f
               #f _ #f
               'electron-head #f #f)
          ($ state 'electron-head))
         (#(#f 'copper #f
               #f _ #f
               'electron-head #f 'copper)
          ($ state 'electron-head))
         (#(#f 'copper #f
               #f _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (#(#f 'copper #f
               #f _ #f
               'copper #f 'electron-head)
          ($ state 'electron-head))
         (#(#f 'copper #f
               #f _ #f
               'electron-head #f 'electron-head)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      ('down
       (match neighbor-grid
         (#('electron-head #f #f
                           #f _ #f
                           #f 'copper #f)
          ($ state 'electron-head))
         (#('electron-head #f 'copper
                           #f _ #f
                           #f 'copper #f)
          ($ state 'electron-head))
         (#(#f #f 'electron-head
               #f _ #f
               #f 'copper #f)
          ($ state 'electron-head))
         (#('copper #f 'electron-head
                    #f _ #f
                    #f 'copper #f)
          ($ state 'electron-head))
         (#('electron-head #f 'electron-head
                           #f _ #f
                           #f 'copper #f)
          ($ state 'electron-head))
         (_ ($ state 'copper))))))
  (^logic-gate bcom x y 'or-gate direction update-wire-state))

(define (^player bcom x y)
  (define position (spawn ^cell (vector x y 2)))
  (define velocity (spawn ^cell #(0 0)))
  (define alive? (spawn ^cell #t))
  (match-lambda*
    (('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 grid-info)
     (match ($ position)
       (#(x y z)
        (match ($ velocity)
          (#(0 0) (values))
          (#(dx dy)
           (match ($ grid-info 'dimensions)
             (#(w h)
              ($ position (vector (modulo (+ x dx) w) (modulo (+ y dy) h) z))
              ($ velocity #(0 0)))))))))
    (('post-tick grid-info)
     ;; Search for objects that were fine to step onto last turn, but
     ;; have become deadly this turn.
     (match ($ position)
       (#(x y z)
        (let lp ((objs ($ grid-info 'occupants x y)))
          (match objs
            (() #f)
            ((obj . rest)
             (match ($ obj 'type)
               ('gate
                ;; Ouch, a gate closed on the player!
                (unless ($ obj 'open?)
                  ($ alive? #f)
                  ($ grid-info 'append-event `(player-death ,x ,y))))
               (_ (lp rest)))))))))
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info from from-x from-y) #f)
    (('alive?) ($ alive?))
    (('explode) ($ alive? #f))
    (('describe) `(player ,($ position), ($ alive?)))
    (('collide other offset grid-info)
     (match ($ position)
       (#(x y z)
        (define (reverse-move)
          (match offset
            (#(dx dy)
             ($ position (vector (- x dx) (- y dy) z)))))
        (match ($ other 'type)
          ('exit
           ($ grid-info 'append-event `(exit ,x ,y)))
          ((or 'block 'bomb)
           (if ($ other 'pushed?)
               ($ grid-info 'append-event `(push ,x ,y))
               (begin
                 (reverse-move)
                 ($ grid-info 'append-event `(bump ,x ,y)))))
          ((or 'gem 'switch 'ghost-gem) #t)
          ('gate
           (unless ($ other 'open?)
             (reverse-move)
             ($ grid-info 'append-event `(bump ,x ,y))))
          (_
           (reverse-move)
           ($ grid-info 'append-event `(bump ,x ,y)))))))))

(define (^event-log bcom)
  (define events (spawn ^cell '()))
  (match-lambda*
    (('append event)
     ($ events (cons event ($ events))))
    (('flush)
     (let ((result (reverse ($ events))))
       ($ events '())
       result))))

(define (^level bcom width height)
  (define player (spawn ^cell))
  (define objects (spawn ^cell '()))
  (define event-log (spawn ^event-log))
  (define gem-collected? (spawn ^cell))

  ;; Spatial partition
  (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 (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 '()))

  (define (wire-state-at who who-x who-y target-x target-y)
    (match ($ (grid-ref/wrap grid target-x target-y))
      (() #f)
      ((obj . _)
       ($ obj 'wire-state grid-info who who-x who-y))))
  ;; flattened 3x3 grid of neighbor states. '_' used to mark the
  ;; center.
  (define (neighbor-grid obj)
    (match ($ obj 'position)
      (#(x y z)
       (vector (wire-state-at obj x y (- x 1) (- y 1))
               (wire-state-at obj x y x (- y 1))
               (wire-state-at obj x y (+ x 1) (- y 1))

               (wire-state-at obj x y (- x 1) y)
               '_
               (wire-state-at obj x y (+ x 1) y)

               (wire-state-at obj x y (- x 1) (+ y 1))
               (wire-state-at obj x y x (+ y 1))
               (wire-state-at obj x y (+ x 1) (+ y 1))))))

  ;; Read-only access to query the grid, but can write events.
  (define (^grid-info bcom)
    (match-lambda*
      (('dimensions) (vector width height))
      (('occupied? x y) (not (null? ($ (grid-ref/wrap grid x y)))))
      (('occupants x y) ($ (grid-ref/wrap grid x y)))
      (('append-event event) ($ event-log 'append event))))
  (define grid-info (spawn ^grid-info))

  (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))
                (remaining (delq obj ($ cell))))
           ($ cell remaining)
           (for-each (lambda (other)
                       ($ other 'exit obj grid-info))
                     remaining))))
      (match resolved-pos
        (#(x y _)
         (let* ((cell (grid-ref grid x y))
                (occupants ($ cell)))
           ($ cell (cons obj occupants))
           (for-each (lambda (other)
                       ($ other 'enter obj grid-info))
                     occupants))))))
  (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)
                       ;; If collision resolution displaced the other
                       ;; object, then recur and check collision for
                       ;; it.
                       (let ((other-pos ($ other 'position)))
                         (unless (equal? other-pos other-prev-pos)
                           (collide other other-pos other-prev-pos)))
                       (lp rest))))))))))))
  (define (iter-objects proc)
    ($ objects
       (let lp ((objs ($ objects)))
         (match objs
           (() '())
           ((obj . rest)
            (proc obj)
            ;; Cull dead objects.
            (if ($ obj 'alive?)
                (cons obj (lp rest))
                (match ($ obj 'position)
                  (#(x y z)
                   ;; Remove from spatial partition.
                   (let ((cell (grid-ref grid x y)))
                     ($ cell (delq obj ($ cell))))
                   ;; If this is a gem, then set a flag that the
                   ;; player has collected it.
                   (when (and (eq? ($ obj 'type) 'gem)
                              (not ($ obj 'previously-collected?)))
                     ($ gem-collected? #t))
                   (lp rest)))))))))
  (define (tick-object obj)
    (let ((prev-pos ($ obj 'position)))
      ($ obj 'tick grid-info)
      ;; Only check collisions for movable objects.
      (let ((desired-pos ($ obj 'position)))
        (unless (equal? prev-pos desired-pos)
          (collide obj desired-pos prev-pos)))))
  (define (tick)
    (let ((player ($ player)))
      ;; Player goes first.
      (when ($ player 'alive?)
        (tick-object player))
      ;; Tick all the non-player objects.
      (iter-objects tick-object)
      ;; Advance Wirewold simulation.
      (let ((neighbor-grids (map neighbor-grid ($ objects))))
        (for-each (lambda (obj neighbor-grid)
                    ($ obj 'update-wire-state grid-info neighbor-grid))
                  ($ objects) neighbor-grids))
      ;; Run post-tick hooks.
      ($ player 'post-tick grid-info)
      (iter-objects (lambda (obj) ($ obj 'post-tick grid-info)))))

  (match-lambda*
    (('tick) (tick))
    (('describe)
     (cons ($ ($ player) 'describe)
           (map (lambda (obj) ($ obj 'describe)) ($ objects))))
    (('add-object obj)
     (if (eq? ($ obj 'type) 'player)
         ($ player obj)
         ($ objects (cons obj ($ objects))))
     (match ($ obj 'position)
       (#(x y _)
        (let ((cell (grid-ref grid x y)))
          ($ cell (cons obj ($ cell)))))))
    (('flush-events)
     ($ event-log 'flush))
    (('gem-collected?) ($ gem-collected?))))