Implement orientation for logic gates

Note that orientation is called "direction" because it's named according to the
direction of electron flow.
This commit is contained in:
Juliana Sims 2024-05-23 14:00:55 -04:00
parent 7803eaba1c
commit 73ffad19f0
5 changed files with 219 additions and 38 deletions

View file

@ -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))

View file

@ -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))

View file

@ -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"/>

View file

@ -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"/>

View file

@ -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)))