Kill player when gate closes on them.

modules/game/actors.scm

@@ -39,6 +39,7 @@
     (('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) #f)
@@ -54,6 +55,7 @@
     (('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)
@@ -80,6 +82,7 @@
     (('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)
@@ -123,6 +126,7 @@
     (('type) 'emitter)
     (('position) position)
     (('tick grid-info) ($ timer (+ ($ timer) 1)))
+    (('post-tick grid-info) #f)
     (('enter obj grid-info) #f)
     (('exit obj grid-info) #f)
     (('wire-state)
@@ -155,6 +159,7 @@
     (('type) 'switch)
     (('position) position)
     (('tick grid-info) #f)
+    (('post-tick grid-info) #f)
     (('enter obj grid-info)
      ($ on? #t))
     (('exit obj grid-info)
@@ -181,6 +186,7 @@
     (('type) 'switch)
     (('position) position)
     (('tick grid-info) #f)
+    (('post-tick grid-info) #f)
     (('enter obj grid-info) #f)
     (('exit obj grid-info) #f)
     (('wire-state) #f)
@@ -210,6 +216,7 @@
     (('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) #f)
@@ -227,6 +234,7 @@
     (('type) 'gate)
     (('position) position)
     (('tick grid-info) #f)
+    (('post-tick grid-info) #f)
     (('enter obj grid-info) #f)
     (('exit obj grid-info) #f)
     (('activate) ($ open? #t))
@@ -245,6 +253,7 @@
     (('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) ($ state))
@@ -268,6 +277,7 @@
 (define (^player bcom x y)
   (define position (spawn ^cell (vector x y 2)))
   (define velocity (spawn ^cell #(0 0)))
+  (define alive? (spawn ^cell #t))
   (define event (spawn ^cell))
   (match-lambda*
     (('type) 'player)
@@ -281,18 +291,39 @@
           ('down #(0 1))
           (_ (error "invalid direction" dir)))))
     (('tick grid-info)
-     ($ event #f)
+     ;; Search for objects that were fine to step onto last turn, but
+     ;; have become deadly this turn.  If
      (match ($ position)
        (#(x y z)
+        ($ event #f)
         (match ($ velocity)
           (#(dx dy)
            ($ position (vector (+ x dx) (+ y dy) z))
            ($ velocity #(0 0)))))))
+    (('post-tick grid-info)
+     (match ($ position)
+       (#(x y z)
+        (let lp ((objs ($ grid-info 'occupants x y)))
+          (match objs
+            ;; All is well.  Move by current velocity.
+            (()
+             (match ($ velocity)
+               (#(dx dy)
+                ($ position (vector (+ x dx) (+ y dy) z))
+                ($ velocity #(0 0)))))
+            ((obj . rest)
+             (match ($ obj 'type)
+               ('gate
+                ;; Ouch, a gate closed on the player!
+                (unless ($ obj 'open?)
+                  ($ alive? #f)
+                  ($ event '(die))))
+               (_ (lp rest)))))))))
     (('enter obj grid-info) #f)
     (('exit obj grid-info) #f)
     (('wire-state) #f)
     (('update-wire-state grid-info) #f)
-    (('alive?) #t)
+    (('alive?) ($ alive?))
     (('describe) `(player ,($ position)))
     (('collide other offset grid-info)
      (define (reverse-move)
@@ -451,28 +482,34 @@
                          (unless (equal? other-pos other-prev-pos)
                            (collide other other-pos other-prev-pos)))
                        (lp rest))))))))))))
-  (define (tick)
-    ;; Tick each object and check for collisions.
+  (define (iter-objects proc)
     ($ objects
        (let lp ((objs ($ objects)))
          (match objs
            (() '())
            ((obj . rest)
-            (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)))
-              ;; Cull dead objects.
-              (if ($ obj 'alive?)
-                  (cons obj (lp rest))
-                  (lp rest)))))))
+            (proc obj)
+            ;; Cull dead objects.
+            (if ($ obj 'alive?)
+                (cons obj (lp rest))
+                (lp rest)))))))
+  (define (tick)
+    ;; Tick each object and check for collisions.
+    (iter-objects
+     (lambda (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))))))
     ;; Advance Wirewold simulation.
     (refresh-wire-grid)
     (for-each (lambda (obj)
                 ($ obj 'update-wire-state grid-info))
-              ($ objects)))
+              ($ objects))
+    ;; Run post-tick hooks.
+    (iter-objects (lambda (obj) ($ obj 'post-tick grid-info))))
 
   (match-lambda*
     (('tick) (tick))