(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
            ^gem
            ^ghost-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* (^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) #f)
    (('update-wire-state grid-info) #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)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('update-wire-state grid-info)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        (let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y))
               (type (wireworld-next type neighbors)))
          (bcom (^wall bcom x y type))))
       (_ #f)))
    (('alive?) #t)
    (('describe) `(wall ,position ,type))
    (('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)
    (('wire-state grid-info)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('update-wire-state grid-info)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        (match ($ position)
          (#(x y z)
           (let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y))
                  (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)
             (let ((x (+ x dx))
                   (y (+ y dy)))
               (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?))))

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

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

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

(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)
       (match (first-non-player-occupant grid-info target-x target-y)
         (#f (pk "no switch target!"))
         (target
          ($ grid-info 'append-event `(floor-switch-off ,x ,y))
          ($ target 'deactivate grid-info)))))
    (('wire-state grid-info) #f)
    (('update-wire-state grid-info) #f)
    (('alive?) #t)
    (('describe) `(floor-switch ,position ,($ on?)))
    (('collide other offset grid-info)
     ($ on? #t)
     (match (first-non-player-occupant grid-info target-x target-y)
         (#f (pk "no switch target!"))
         (target
          ($ grid-info 'append-event `(floor-switch-on ,x ,y))
          ($ target 'activate grid-info))))))

(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) #f)
    (('update-wire-state grid-info)
     (if ($ on?)
         (let ((t (1- ($ timer))))
           ($ timer t)
           (when (= t 0)
             ($ on? #f)
             (match (first-non-player-occupant grid-info target-x target-y)
               (#f (pk "no switch target!"))
               (target
                ($ grid-info 'append-event `(electric-switch-off ,x ,y))
                ($ target 'deactivate grid-info)))))
         (when (>= ($ grid-info 'wireworld-neighbor-count x y) 1)
           ($ on? #t)
           ($ timer 2)
           (match (first-non-player-occupant grid-info target-x target-y)
             (#f (pk "no switch target!"))
             (target
              ($ grid-info 'append-event `(electric-switch-on ,x ,y))
              ($ target 'activate grid-info))))))
    (('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 electron? (spawn ^cell))
  (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) #f)
    (('post-tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state grid-info) ($ state))
    (('update-wire-state grid-info)
     (match ($ state)
       ('electron-head ($ state 'electron-tail))
       ('electron-tail ($ state 'copper))
       ('copper
        (if ($ electron?)
            (begin
              ($ state 'electron-head)
              ($ electron? #f)
              ($ grid-info 'append-event `(receive-electron ,x ,y)))
            (let ((neighbors ($ grid-info 'wireworld-neighbor-count x y)))
              (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) ($ electron? #t))
    (('alive?) #t)
    (('describe) `(electron-warp ,position ,($ state)))
    (('collide other offset grid-info) #f)))

(define (^gem bcom x y)
  (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) #f)
    (('update-wire-state grid-info) #f)
    (('alive?) (not ($ picked-up?)))
    (('describe) `(gem ,position))
    (('collide other offset grid-info)
     (when (eq? ($ other 'type) 'player)
       ($ picked-up? #t)
       ($ grid-info 'append-event `(pickup ,x ,y))))))

(define (^ghost-gem bcom x y)
  (define position (vector x y 1))
  (match-lambda*
    (('type) 'ghost-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) #f)
    (('update-wire-state grid-info) #f)
    (('alive?) #t)
    (('describe) `(ghost-gem ,position))
    (('collide other offset grid-info) #f)))

(define (^gate bcom x y)
  (define position (vector x y 1))
  (define open? (spawn ^cell))
  (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)
     ($ open? #t)
     ($ grid-info 'append-event `(gate-open ,x ,y)))
    (('deactivate grid-info)
     ($ open? #f)
     ($ grid-info 'append-event `(gate-close ,x ,y)))
    (('wire-state grid-info) #f)
    (('update-wire-state grid-info) #f)
    (('alive?) #t)
    (('open?) ($ open?))
    (('describe) `(gate ,position ,($ open?)))
    (('collide other offset grid-info) #f)))

(define (^logic-gate bcom x y name 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) ($ state))
    (('update-wire-state grid-info)
     (match ($ state)
       ('electron-head ($ state 'electron-tail))
       ('electron-tail ($ state 'copper))
       ('copper
        (update-wire-state state ($ grid-info 'wireworld-neighbor-grid x y)))))
    (('alive?) #t)
    (('describe) `(,name ,position ,($ state)))
    (('collide other offset grid-info) #f)))

(define direction:right 1)
(define direction:left 2)
(define direction:up 3)
(define direction:down 4)

(define (^and-gate bcom x y direction)
  (define (update-wire-state state neighbor-grid)
    (match direction
      (direction:right
       (match neighbor-grid
         (#('electron-head #f #f
                           #f _ 'copper
                           'electron-head #f #f)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      (direction:left
       (match neighbor-grid
         (#(#f #f 'electron-head
               'copper _ #f
               #f #f 'electron-head)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      (direction:up
       (match neighbor-grid
         (#(#f 'copper #f
               #f _ #f
               'electron-head #f 'electron-head)
          ($ state 'electron-head))
         (_ ($ state 'copper))))
      (direction: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 update-wire-state))

(define (^xor-gate bcom x y direction)
  (define (update-wire-state state neighbor-grid)
    (match direction
      (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))))
      (direction: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))))
      (direction: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))))
      (direction: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 update-wire-state))

(define (^or-gate bcom x y direction)
  (define (update-wire-state state neighbor-grid)
    (match direction
      (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))))
      (direction: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))))
      (direction: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))))
      (direction: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 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)
          (#(dx dy)
           ($ position (vector (+ x dx) (+ y dy) 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) #f)
    (('alive?) ($ alive?))
    (('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)))
          ('block
           (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))

  ;; 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-grid (make-grid #f))
  (define (refresh-wire-grid)
    (for-each-coord
     (lambda (x y)
       (let ((obj-cell (grid-ref grid x y))
             (wire-cell (grid-ref wire-grid x y)))
         (match ($ obj-cell)
           (() #f)
           ;; TODO: Handle tiles with many occupants.  Might not be
           ;; necessary in practice.  Actually this *WILL* cause
           ;; problems for electron warps, at least, since they are
           ;; invisible and the player can stand over them.
           ((refr . _)
            ($ wire-cell ($ refr 'wire-state grid-info))))))))
  (define (wire-state-at x y)
    ($ (grid-ref/wrap wire-grid x y)))
  (define (neighbor-count x y)
    (define (check x y)
      (match (wire-state-at x y)
        ('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)
       (check (- x 1) (+ y 1))
       (check x (+ y 1))
       (check (+ x 1) (+ y 1))))
  ;; flattened 3x3 grid of neighbor states. '_' used to mark the
  ;; center.
  (define (neighbor-grid x y)
    (vector (wire-state-at (- x 1) (- y 1))
            (wire-state-at x (- y 1))
            (wire-state-at (+ x 1) (- y 1))

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

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

  ;; Read-only access to query the grid.
  (define (^grid-info bcom)
    (match-lambda*
      (('occupied? x y)
       (not (null? ($ (grid-ref grid x y)))))
      (('occupants x y)
       ($ (grid-ref grid x y)))
      ;; How many electron heads around (x, y)?
      (('wireworld-neighbor-count x y)
       (neighbor-count x y))
      (('wireworld-neighbor-grid x y)
       (neighbor-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))
                (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.
      (refresh-wire-grid)
      (for-each (lambda (obj)
                  ($ obj 'update-wire-state grid-info))
                ($ objects))
      ;; 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))))