Add basic AND gate and electric switch.

game.scm

@@ -280,6 +280,12 @@
 (define (draw-gate pos open?)
   (draw-tile context tileset (if open? 46 45) (vec2-x pos) (vec2-y pos)))
 
+(define (draw-and-gate pos)
+  (draw-tile context tileset 42 (vec2-x pos) (vec2-y pos)))
+
+(define (draw-electric-switch pos on?)
+  (draw-tile context tileset (if on? 7 6) (vec2-x pos) (vec2-y pos)))
+
 (define (draw-object obj)
   (match obj
     (#f #f)
@@ -290,7 +296,9 @@
     (('clock-emitter pos) #t)           ; drawn via background
     (('floor-switch pos on?) (draw-floor-switch pos on?))
     (('gem pos) (draw-gem pos))
-    (('gate pos open?) (draw-gate pos open?))))
+    (('gate pos open?) (draw-gate pos open?))
+    (('and-gate pos) (draw-and-gate pos))
+    (('electric-switch pos on?) (draw-electric-switch pos on?))))
 
 (define (draw-background)
   (let* ((bv (level-background *level*))

modules/game/actors.scm

@@ -9,6 +9,8 @@
             ^floor-switch
             ^gate
             ^gem
+            ^and-gate
+            ^electric-switch
             ^player
             ^level))
 
@@ -134,10 +136,18 @@
          'copper))))
     (('update-wire-state grid-info) #f)
     (('alive?) #t)
-    (('set-wire-state type) #f)
     (('describe) `(clock-emitter ,position))
     (('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))
@@ -150,20 +160,48 @@
     (('exit obj grid-info)
      (when (= (length ($ grid-info 'occupants x y)) 1)
        ($ on? #f)
-       (match ($ grid-info 'occupants target-x target-y)
+       (match (first-non-player-occupant grid-info target-x target-y)
-         (() (pk "no switch target!"))
+         (#f (pk "no switch target!"))
-         ((target . _)
+         (target ($ target 'deactivate)))))
-          ($ target 'deactivate)))))
     (('wire-state) #f)
     (('update-wire-state grid-info) #f)
     (('alive?) #t)
     (('describe) `(floor-switch ,position ,($ on?)))
     (('collide other offset grid-info)
      ($ on? #t)
-     (match ($ grid-info 'occupants target-x target-y)
+     (match (first-non-player-occupant grid-info target-x target-y)
-       (() (pk "no switch target!"))
+         (#f (pk "no switch target!"))
-       ((target . _)
+         (target ($ target 'activate))))))
-        ($ target 'activate))))))
+
+(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) 'switch)
+    (('position) position)
+    (('tick grid-info) #f)
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
+    (('wire-state) #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 ($ target 'deactivate)))))
+         (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 ($ target 'activate))))))
+    (('alive?) #t)
+    (('describe) `(electric-switch ,position ,($ on?)))
+    (('collide other offset grid-info) #f)))
 
 (define (^gem bcom x y)
   (define position (vector x y 1))
@@ -200,6 +238,35 @@
     (('describe) `(gate ,position ,($ open?)))
     (('collide other offset grid-info) #f)))
 
+(define (^and-gate bcom x y)
+  (define position (vector x y 0))
+  (define state (spawn ^cell 'copper))
+  (match-lambda*
+    (('type) 'emitter)
+    (('position) position)
+    (('tick grid-info) #f)
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
+    (('wire-state) ($ state))
+    (('update-wire-state grid-info)
+     (match ($ state)
+       ('electron-head ($ state 'electron-tail))
+       ('electron-tail ($ state 'copper))
+       ('copper
+        ;; TODO: Match other shapes? This only allows left-to-right
+        ;; circuit flow.
+        (match (pk 'GRID ($ grid-info 'wireworld-neighbor-grid x y))
+          (#('electron-head #f #f
+                            #f _ 'copper
+                            'electron-head #f #f)
+           (pk 'COOL)
+           ($ state 'electron-head))
+          (_ ($ state 'copper)))))
+     (pk 'NEW-STATE ($ state)))
+    (('alive?) #t)
+    (('describe) `(and-gate ,position))
+    (('collide other offset grid-info) #f)))
+
 (define (^player bcom x y)
   (define position (spawn ^cell (vector x y 2)))
   (define velocity (spawn ^cell #(0 0)))

modules/game/level.scm

@@ -42,9 +42,14 @@
                             (spawn ^floor-switch x y target-x target-y)))
                        (9 (and spawn-gem? (spawn ^gem x y)))
                        (10 (spawn ^gate x y))
+                       (11 (spawn ^and-gate x y))
+                       (12 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
+                                 (target-y (bytevector-u8-ref objects (+ i 4))))
+                             (spawn ^electric-switch x y target-x target-y)))
                        (id (error "invalid level object" id))))
                 (i* (+ i (match id
-                           (8 5)            ; floor-switch
+                           ;; floor-switch or electric-switch
+                           ((or 8 12) 5)
                            (_ 3)))))
             (when obj
               ($ level* 'add-object obj))

modules/game/levels/level-3.tmx

@@ -7,7 +7,7 @@
 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
 23,23,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23,23,23,23,
 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,24,24,24,23,
-23,49,3,3,3,24,3,3,3,3,3,3,24,24,24,23,24,24,24,23,
+23,24,49,3,3,24,3,3,3,3,3,3,24,24,24,23,24,24,24,23,
 23,24,24,24,24,24,24,24,24,24,24,24,24,3,24,23,24,24,24,23,
 23,24,24,24,24,24,49,3,3,3,3,3,24,24,24,24,24,24,24,23,
 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,24,24,24,23,
@@ -27,13 +27,12 @@
     <property name="kind" value="copper"/>
    </properties>
   </object>
-  <object id="7" type="floor-switch" gid="25" x="80" y="96" width="16" height="16">
+  <object id="8" type="electric-switch" gid="8" x="224" y="80" width="16" height="16">
    <properties>
-    <property name="target-x" type="int" value="11"/>
+    <property name="target-x" type="int" value="15"/>
-    <property name="target-y" type="int" value="7"/>
+    <property name="target-y" type="int" value="6"/>
    </properties>
   </object>
-  <object id="8" type="electric-switch" gid="8" x="224" y="80" width="16" height="16"/>
   <object id="9" type="gate" gid="46" x="240" y="96" width="16" height="16"/>
   <object id="10" type="and-gate" gid="43" x="192" y="80" width="16" height="16"/>
  </objectgroup>

scripts/compile-map.scm

@@ -555,6 +555,8 @@ the default ORIENTATION value of 'orthogonal' is supported."
 (define obj:floor-switch 8)
 (define obj:gem 9)
 (define obj:gate 10)
+(define obj:and-gate 11)
+(define obj:electric-switch 12)
 
 (define (compile-environment-layer tile-map layer-name)
   (let ((tw (tile-map-tile-width tile-map))
@@ -601,9 +603,10 @@ the default ORIENTATION value of 'orthogonal' is supported."
                                            (assq-ref properties 'target-y)))
                       ('gem (list x y obj:gem))
                       ('gate (list x y obj:gate))
-                      ;; TODO: Implement these
+                      ('and-gate (list x y obj:and-gate))
-                      ('and-gate (list x y obj:block:copper))
+                      ('electric-switch (list x y obj:electric-switch
-                      ('electric-switch (list x y obj:wall:copper))
+                                              (assq-ref properties 'target-x)
+                                              (assq-ref properties 'target-y)))
                       (_ (error "unsupported object type" type)))))
                 (object-layer-objects layer))))