From 73ffad19f0376710f36f3d03f9e41f6b7bc032a7 Mon Sep 17 00:00:00 2001
From: Juliana Sims <juli@incana.org>
Date: Thu, 23 May 2024 14:00:55 -0400
Subject: [PATCH] Implement orientation for logic gates

Note that orientation is called "direction" because it's named according to the
direction of electron flow.
---
 modules/game/actors.scm         | 200 +++++++++++++++++++++++++++-----
 modules/game/level.scm          |  10 +-
 modules/game/levels/level-3.tmx |   6 +-
 modules/game/levels/level-4.tmx |  18 ++-
 scripts/compile-map.scm         |  23 +++-
 5 files changed, 219 insertions(+), 38 deletions(-)

diff --git a/modules/game/actors.scm b/modules/game/actors.scm
index 8bd0ca5..b65b653 100644
--- a/modules/game/actors.scm
+++ b/modules/game/actors.scm
@@ -365,36 +365,58 @@
     (('exit obj grid-info) #f)
     (('wire-state grid-info) ($ state))
     (('update-wire-state grid-info)
-     (update-wire-state 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 (^and-gate bcom x y)
-  (define (update-wire-state 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 ($ grid-info 'wireworld-neighbor-grid x y)
+(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)
-  (define (update-wire-state 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 ($ grid-info 'wireworld-neighbor-grid x y)
+(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)
@@ -411,18 +433,71 @@
                     #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)
-  (define (update-wire-state 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 ($ grid-info 'wireworld-neighbor-grid x y)
+(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)
@@ -443,6 +518,75 @@
                            #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))
 
diff --git a/modules/game/level.scm b/modules/game/level.scm
index 75f93b3..5990a0d 100644
--- a/modules/game/level.scm
+++ b/modules/game/level.scm
@@ -74,15 +74,18 @@
                                (spawn ^ghost-gem x y)
                                (spawn ^gem x y)))
                         (10 (spawn ^gate x y))
-                        (11 (spawn ^and-gate x y))
+                        (11 (spawn ^and-gate x y
+                                   (bytevector-u8-ref objects (+ i 3))))
                         (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)))
-                        (13 (spawn ^xor-gate x y))
+                        (13 (spawn ^xor-gate x y
+                                   (bytevector-u8-ref objects (+ i 3))))
                         (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))
+                        (15 (spawn ^or-gate x y
+                                   (bytevector-u8-ref objects (+ i 3))))
                         (16 (spawn ^switched-emitter x y 4))
                         (id (error "invalid level object" id))))
                  (i* (+ i (match id
@@ -90,6 +93,7 @@
                             ;; electric-switch
                             ;; electron-warp
                             ((or 8 12 14) 5)
+                            ((or 11 13 15) 4)
                             (_ 3)))))
             (when obj
               ($ level* 'add-object obj))
diff --git a/modules/game/levels/level-3.tmx b/modules/game/levels/level-3.tmx
index f44c48b..cc1d396 100644
--- a/modules/game/levels/level-3.tmx
+++ b/modules/game/levels/level-3.tmx
@@ -34,7 +34,11 @@
    </properties>
   </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="10" type="and-gate" gid="43" x="192" y="80" width="16" height="16">
+   <properties>
+    <property name="direction" value="right"/>
+   </properties>
+  </object>
   <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"/>
diff --git a/modules/game/levels/level-4.tmx b/modules/game/levels/level-4.tmx
index ad44008..c27cef9 100644
--- a/modules/game/levels/level-4.tmx
+++ b/modules/game/levels/level-4.tmx
@@ -34,9 +34,21 @@
    </properties>
   </object>
   <object id="9" type="gate" gid="46" x="240" y="112" width="16" height="16"/>
-  <object id="13" type="xor-gate" gid="45" x="144" y="96" width="16" height="16"/>
-  <object id="15" type="and-gate" gid="43" x="176" y="112" width="16" height="16"/>
-  <object id="17" type="or-gate" gid="44" x="144" y="128" width="16" height="16"/>
+  <object id="13" type="xor-gate" gid="45" x="144" y="96" width="16" height="16">
+   <properties>
+    <property name="direction" value="right"/>
+   </properties>
+  </object>
+  <object id="15" type="and-gate" gid="43" x="176" y="112" width="16" height="16">
+   <properties>
+    <property name="direction" value="right"/>
+   </properties>
+  </object>
+  <object id="17" type="or-gate" gid="44" x="144" y="128" width="16" height="16">
+   <properties>
+    <property name="direction" value="right"/>
+   </properties>
+  </object>
   <object id="18" type="floor-switch" gid="25" x="112" y="48" width="16" height="16">
    <properties>
     <property name="target-x" type="int" value="5"/>
diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm
index 0c5d197..cb93e62 100644
--- a/scripts/compile-map.scm
+++ b/scripts/compile-map.scm
@@ -564,6 +564,11 @@ the default ORIENTATION value of 'orthogonal' is supported."
 (define obj:or-gate 15)
 (define obj:switched-emitter 16)
 
+(define direction:right 1)
+(define direction:left 2)
+(define direction:up 3)
+(define direction:down 4)
+
 (define (compile-environment-layer tile-map layer-name)
   (let ((tw (tile-map-tile-width tile-map))
         (th (tile-map-tile-height tile-map))
@@ -589,6 +594,12 @@ the default ORIENTATION value of 'orthogonal' is supported."
                 (iota (tile-layer-height layer)))))
 
 (define (compile-object-layer tile-map layer-name)
+  (define parse-direction
+    (match-lambda
+      ("right" direction:right)
+      ("left" direction:left)
+      ("up" direction:up)
+      ("down" direction:down)))
   (let ((tw (tile-map-tile-width tile-map))
         (th (tile-map-tile-height tile-map))
         (layer (tile-map-layer-ref tile-map layer-name)))
@@ -610,9 +621,15 @@ 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))
-                      ('and-gate (list x y obj:and-gate))
-                      ('xor-gate (list x y obj:xor-gate))
-                      ('or-gate (list x y obj:or-gate))
+                      ('and-gate (list x y obj:and-gate
+                                       (parse-direction
+                                        (assq-ref properties 'direction))))
+                      ('xor-gate (list x y obj:xor-gate
+                                       (parse-direction
+                                        (assq-ref properties 'direction))))
+                      ('or-gate (list x y obj:or-gate
+                                      (parse-direction
+                                       (assq-ref properties 'direction))))
                       ('electric-switch (list x y obj:electric-switch
                                               (assq-ref properties 'target-x)
                                               (assq-ref properties 'target-y)))