From 9b88cb19c0e7311470ef404c496e368bfdab3ddd Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 22 May 2024 12:35:56 -0400
Subject: [PATCH] Add electron warp terminals.

---
 game.scm                        |  7 +++-
 modules/game/actors.scm         | 50 ++++++++++++++++++++++++---
 modules/game/level.scm          |  9 +++--
 modules/game/levels/level-3.tmx | 44 +++++++++++++++++-------
 modules/game/levels/tiles.tsx   | 60 +++++++++++++++++++++++++++++++++
 scripts/compile-map.scm         |  6 +++-
 6 files changed, 154 insertions(+), 22 deletions(-)

diff --git a/game.scm b/game.scm
index 2eac3b5..11cc699 100644
--- a/game.scm
+++ b/game.scm
@@ -301,6 +301,10 @@
 (define (draw-electric-switch pos on?)
   (draw-tile context tileset (if on? 7 6) (vec2-x pos) (vec2-y pos)))
 
+(define (draw-electron-warp pos state)
+  (draw-tile context tileset 71 (vec2-x pos) (vec2-y pos))
+  (draw-wire-state pos state))
+
 (define (draw-object obj)
   (match obj
     (#f #f)
@@ -315,7 +319,8 @@
     (('and-gate pos state) (draw-logic-gate pos state 42))
     (('or-gate pos state) (draw-logic-gate pos state 43))
     (('xor-gate pos state) (draw-logic-gate pos state 44))
-    (('electric-switch pos on?) (draw-electric-switch pos on?))))
+    (('electric-switch pos on?) (draw-electric-switch pos on?))
+    (('electron-warp pos state) (draw-electron-warp pos state))))
 
 (define (draw-background)
   (let ((bg (level-background *level*))
diff --git a/modules/game/actors.scm b/modules/game/actors.scm
index 9e1593e..3a4ce1f 100644
--- a/modules/game/actors.scm
+++ b/modules/game/actors.scm
@@ -13,6 +13,7 @@
             ^xor-gate
             ^or-gate
             ^electric-switch
+            ^electron-warp
             ^player
             ^level))
 
@@ -31,9 +32,6 @@
     ((new-val)
      (bcom (^cell bcom new-val)))))
 
-;; TODO: Add layer info to 'describe' output for sorting sprites when
-;; rendering.
-
 ;; TODO: Port actor-lib methods and use it.
 (define (^exit bcom x y)
   (define position (vector x y 1))
@@ -211,6 +209,47 @@
     (('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))
+            (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))
+                  ($ 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))
@@ -403,7 +442,6 @@
     (('enter obj grid-info) #f)
     (('exit obj grid-info) #f)
     (('wire-state grid-info) #f)
-    (('update-wire-state grid-info) #f)
     (('alive?) ($ alive?))
     (('describe) `(player ,($ position)))
     (('collide other offset grid-info)
@@ -468,7 +506,9 @@
          (match ($ obj-cell)
            (() #f)
            ;; TODO: Handle tiles with many occupants.  Might not be
-           ;; necessary in practice.
+           ;; 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)
diff --git a/modules/game/level.scm b/modules/game/level.scm
index 46b4114..f5cfef0 100644
--- a/modules/game/level.scm
+++ b/modules/game/level.scm
@@ -77,11 +77,16 @@
                                   (target-y (bytevector-u8-ref objects (+ i 4))))
                               (spawn ^electric-switch x y target-x target-y)))
                         (13 (spawn ^xor-gate x y))
+                        (14 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
+                                  (target-y (bytevector-u8-ref objects (+ i 4))))
+                              (spawn ^electron-warp x y target-x target-y)))
                         (15 (spawn ^or-gate x y))
                         (id (error "invalid level object" id))))
                  (i* (+ i (match id
-                            ;; floor-switch or electric-switch
-                            ((or 8 12) 5)
+                            ;; floor-switch
+                            ;; electric-switch
+                            ;; electron-warp
+                            ((or 8 12 14) 5)
                             (_ 3)))))
             (when obj
               ($ level* 'add-object obj))
diff --git a/modules/game/levels/level-3.tmx b/modules/game/levels/level-3.tmx
index f5ca22d..f44c48b 100644
--- a/modules/game/levels/level-3.tmx
+++ b/modules/game/levels/level-3.tmx
@@ -1,21 +1,21 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="20" height="15" tilewidth="16" tileheight="16" infinite="0" nextlayerid="3" nextobjectid="13">
+<map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="20" height="15" tilewidth="16" tileheight="16" infinite="0" nextlayerid="3" nextobjectid="23">
  <tileset firstgid="1" source="tiles.tsx"/>
  <layer id="1" name="background" width="20" height="15">
   <data encoding="csv">
 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
-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,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,
-23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,24,28,24,23,
-23,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,24,24,24,23,
-23,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,24,24,24,23,
-23,23,24,24,24,24,24,24,24,24,24,24,24,23,23,23,23,23,23,23,
-23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
+81,83,83,82,83,83,83,82,83,83,83,83,82,83,83,84,23,23,23,23,
+85,24,24,24,24,24,24,24,24,24,24,24,24,24,24,106,81,82,82,84,
+105,24,24,24,24,24,24,24,24,24,24,24,24,24,24,106,105,24,24,86,
+105,24,49,3,3,24,3,3,3,3,3,3,24,24,24,106,105,24,24,106,
+85,24,24,24,24,24,24,24,24,24,24,24,24,3,24,106,105,24,24,106,
+85,24,24,24,24,24,49,3,3,3,3,3,24,24,24,24,24,24,24,106,
+85,24,24,24,24,24,24,24,24,24,24,24,24,24,24,106,105,24,24,106,
+85,24,24,24,24,24,24,24,24,24,24,24,24,24,24,106,105,28,24,86,
+105,24,24,24,24,24,24,24,24,24,24,24,24,24,81,104,105,24,24,86,
+105,49,3,3,24,61,61,66,24,24,24,24,24,24,106,23,105,24,24,86,
+85,24,24,24,24,24,24,64,61,61,24,3,3,24,86,23,101,102,102,104,
+101,103,103,102,102,102,103,102,103,103,102,102,102,102,104,23,23,23,23,23,
 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23
 </data>
@@ -35,5 +35,23 @@
   </object>
   <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"/>
+  <object id="13" type="electric-switch" gid="8" x="208" y="176" width="16" height="16">
+   <properties>
+    <property name="target-x" type="int" value="11"/>
+    <property name="target-y" type="int" value="10"/>
+   </properties>
+  </object>
+  <object id="21" type="electron-warp" gid="72" x="64" y="160" width="16" height="16">
+   <properties>
+    <property name="target-x" type="int" value="10"/>
+    <property name="target-y" type="int" value="11"/>
+   </properties>
+  </object>
+  <object id="22" type="electron-warp" gid="72" x="160" y="176" width="16" height="16">
+   <properties>
+    <property name="target-x" type="int" value="4"/>
+    <property name="target-y" type="int" value="10"/>
+   </properties>
+  </object>
  </objectgroup>
 </map>
diff --git a/modules/game/levels/tiles.tsx b/modules/game/levels/tiles.tsx
index 905737f..8b699dc 100644
--- a/modules/game/levels/tiles.tsx
+++ b/modules/game/levels/tiles.tsx
@@ -13,4 +13,64 @@
  </tile>
  <tile id="27" type="exit"/>
  <tile id="48" type="clock-emitter"/>
+ <tile id="80" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="81" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="82" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="83" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="84" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="85" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="100" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="101" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="102" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="103" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="104" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
+ <tile id="105" type="wall">
+  <properties>
+   <property name="kind" value="brick"/>
+  </properties>
+ </tile>
 </tileset>
diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm
index 982f222..b9c0c4e 100644
--- a/scripts/compile-map.scm
+++ b/scripts/compile-map.scm
@@ -306,7 +306,7 @@ the default ORIENTATION value of 'orthogonal' is supported."
             (match type
               ((or 'string 'file) value)
               ('bool (not (string=? value "false")))
-              ((or 'int 'float) (string->number value))
+              ((or 'int 'float 'object) (string->number value))
               ('color
                (make-color (parse-color-channel value 3)
                            (parse-color-channel value 5)
@@ -560,6 +560,7 @@ the default ORIENTATION value of 'orthogonal' is supported."
 (define obj:and-gate 11)
 (define obj:electric-switch 12)
 (define obj:xor-gate 13)
+(define obj:electron-warp 14)
 (define obj:or-gate 15)
 
 (define (compile-environment-layer tile-map layer-name)
@@ -613,6 +614,9 @@ the default ORIENTATION value of 'orthogonal' is supported."
                       ('electric-switch (list x y obj:electric-switch
                                               (assq-ref properties 'target-x)
                                               (assq-ref properties 'target-y)))
+                      ('electron-warp (list x y obj:electron-warp
+                                            (assq-ref properties 'target-x)
+                                            (assq-ref properties 'target-y)))
                       (_ (error "unsupported object type" type)))))
                 (object-layer-objects layer))))