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:
parent
7803eaba1c
commit
73ffad19f0
5 changed files with 219 additions and 38 deletions
|
@ -365,36 +365,58 @@
|
||||||
(('exit obj grid-info) #f)
|
(('exit obj grid-info) #f)
|
||||||
(('wire-state grid-info) ($ state))
|
(('wire-state grid-info) ($ state))
|
||||||
(('update-wire-state grid-info)
|
(('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)
|
(('alive?) #t)
|
||||||
(('describe) `(,name ,position ,($ state)))
|
(('describe) `(,name ,position ,($ state)))
|
||||||
(('collide other offset grid-info) #f)))
|
(('collide other offset grid-info) #f)))
|
||||||
|
|
||||||
(define (^and-gate bcom x y)
|
(define direction:right 1)
|
||||||
(define (update-wire-state state grid-info)
|
(define direction:left 2)
|
||||||
(match ($ state)
|
(define direction:up 3)
|
||||||
('electron-head ($ state 'electron-tail))
|
(define direction:down 4)
|
||||||
('electron-tail ($ state 'copper))
|
|
||||||
('copper
|
(define (^and-gate bcom x y direction)
|
||||||
;; TODO: Match other shapes? This only allows left-to-right
|
(define (update-wire-state state neighbor-grid)
|
||||||
;; circuit flow.
|
(match direction
|
||||||
(match ($ grid-info 'wireworld-neighbor-grid x y)
|
(direction:right
|
||||||
|
(match neighbor-grid
|
||||||
(#('electron-head #f #f
|
(#('electron-head #f #f
|
||||||
#f _ 'copper
|
#f _ 'copper
|
||||||
'electron-head #f #f)
|
'electron-head #f #f)
|
||||||
($ state 'electron-head))
|
($ 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))))))
|
(_ ($ state 'copper))))))
|
||||||
(^logic-gate bcom x y 'and-gate update-wire-state))
|
(^logic-gate bcom x y 'and-gate update-wire-state))
|
||||||
|
|
||||||
(define (^xor-gate bcom x y)
|
(define (^xor-gate bcom x y direction)
|
||||||
(define (update-wire-state state grid-info)
|
(define (update-wire-state state neighbor-grid)
|
||||||
(match ($ state)
|
(match direction
|
||||||
('electron-head ($ state 'electron-tail))
|
(direction:right
|
||||||
('electron-tail ($ state 'copper))
|
(match neighbor-grid
|
||||||
('copper
|
|
||||||
;; TODO: Match other shapes? This only allows left-to-right
|
|
||||||
;; circuit flow.
|
|
||||||
(match ($ grid-info 'wireworld-neighbor-grid x y)
|
|
||||||
(#('electron-head #f #f
|
(#('electron-head #f #f
|
||||||
#f _ 'copper
|
#f _ 'copper
|
||||||
#f #f #f)
|
#f #f #f)
|
||||||
|
@ -411,18 +433,71 @@
|
||||||
#f _ 'copper
|
#f _ 'copper
|
||||||
'electron-head #f #f)
|
'electron-head #f #f)
|
||||||
($ state 'electron-head))
|
($ 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))))))
|
(_ ($ state 'copper))))))
|
||||||
(^logic-gate bcom x y 'xor-gate update-wire-state))
|
(^logic-gate bcom x y 'xor-gate update-wire-state))
|
||||||
|
|
||||||
(define (^or-gate bcom x y)
|
(define (^or-gate bcom x y direction)
|
||||||
(define (update-wire-state state grid-info)
|
(define (update-wire-state state neighbor-grid)
|
||||||
(match ($ state)
|
(match direction
|
||||||
('electron-head ($ state 'electron-tail))
|
(direction:right
|
||||||
('electron-tail ($ state 'copper))
|
(match neighbor-grid
|
||||||
('copper
|
|
||||||
;; TODO: Match other shapes? This only allows left-to-right
|
|
||||||
;; circuit flow.
|
|
||||||
(match ($ grid-info 'wireworld-neighbor-grid x y)
|
|
||||||
(#('electron-head #f #f
|
(#('electron-head #f #f
|
||||||
#f _ 'copper
|
#f _ 'copper
|
||||||
#f #f #f)
|
#f #f #f)
|
||||||
|
@ -443,6 +518,75 @@
|
||||||
#f _ 'copper
|
#f _ 'copper
|
||||||
'electron-head #f #f)
|
'electron-head #f #f)
|
||||||
($ state 'electron-head))
|
($ 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))))))
|
(_ ($ state 'copper))))))
|
||||||
(^logic-gate bcom x y 'or-gate update-wire-state))
|
(^logic-gate bcom x y 'or-gate update-wire-state))
|
||||||
|
|
||||||
|
|
|
@ -74,15 +74,18 @@
|
||||||
(spawn ^ghost-gem x y)
|
(spawn ^ghost-gem x y)
|
||||||
(spawn ^gem x y)))
|
(spawn ^gem x y)))
|
||||||
(10 (spawn ^gate 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)))
|
(12 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
|
||||||
(target-y (bytevector-u8-ref objects (+ i 4))))
|
(target-y (bytevector-u8-ref objects (+ i 4))))
|
||||||
(spawn ^electric-switch x y target-x target-y)))
|
(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)))
|
(14 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
|
||||||
(target-y (bytevector-u8-ref objects (+ i 4))))
|
(target-y (bytevector-u8-ref objects (+ i 4))))
|
||||||
(spawn ^electron-warp x y target-x target-y)))
|
(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))
|
(16 (spawn ^switched-emitter x y 4))
|
||||||
(id (error "invalid level object" id))))
|
(id (error "invalid level object" id))))
|
||||||
(i* (+ i (match id
|
(i* (+ i (match id
|
||||||
|
@ -90,6 +93,7 @@
|
||||||
;; electric-switch
|
;; electric-switch
|
||||||
;; electron-warp
|
;; electron-warp
|
||||||
((or 8 12 14) 5)
|
((or 8 12 14) 5)
|
||||||
|
((or 11 13 15) 4)
|
||||||
(_ 3)))))
|
(_ 3)))))
|
||||||
(when obj
|
(when obj
|
||||||
($ level* 'add-object obj))
|
($ level* 'add-object obj))
|
||||||
|
|
|
@ -34,7 +34,11 @@
|
||||||
</properties>
|
</properties>
|
||||||
</object>
|
</object>
|
||||||
<object id="9" type="gate" gid="46" x="240" y="96" 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"/>
|
<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">
|
<object id="13" type="electric-switch" gid="8" x="208" y="176" width="16" height="16">
|
||||||
<properties>
|
<properties>
|
||||||
<property name="target-x" type="int" value="11"/>
|
<property name="target-x" type="int" value="11"/>
|
||||||
|
|
|
@ -34,9 +34,21 @@
|
||||||
</properties>
|
</properties>
|
||||||
</object>
|
</object>
|
||||||
<object id="9" type="gate" gid="46" x="240" y="112" width="16" height="16"/>
|
<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="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"/>
|
<properties>
|
||||||
<object id="17" type="or-gate" gid="44" x="144" y="128" width="16" height="16"/>
|
<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">
|
<object id="18" type="floor-switch" gid="25" x="112" y="48" width="16" height="16">
|
||||||
<properties>
|
<properties>
|
||||||
<property name="target-x" type="int" value="5"/>
|
<property name="target-x" type="int" value="5"/>
|
||||||
|
|
|
@ -564,6 +564,11 @@ the default ORIENTATION value of 'orthogonal' is supported."
|
||||||
(define obj:or-gate 15)
|
(define obj:or-gate 15)
|
||||||
(define obj:switched-emitter 16)
|
(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)
|
(define (compile-environment-layer tile-map layer-name)
|
||||||
(let ((tw (tile-map-tile-width tile-map))
|
(let ((tw (tile-map-tile-width tile-map))
|
||||||
(th (tile-map-tile-height 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)))))
|
(iota (tile-layer-height layer)))))
|
||||||
|
|
||||||
(define (compile-object-layer tile-map layer-name)
|
(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))
|
(let ((tw (tile-map-tile-width tile-map))
|
||||||
(th (tile-map-tile-height tile-map))
|
(th (tile-map-tile-height tile-map))
|
||||||
(layer (tile-map-layer-ref tile-map layer-name)))
|
(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)))
|
(assq-ref properties 'target-y)))
|
||||||
('gem (list x y obj:gem))
|
('gem (list x y obj:gem))
|
||||||
('gate (list x y obj:gate))
|
('gate (list x y obj:gate))
|
||||||
('and-gate (list x y obj:and-gate))
|
('and-gate (list x y obj:and-gate
|
||||||
('xor-gate (list x y obj:xor-gate))
|
(parse-direction
|
||||||
('or-gate (list x y obj:or-gate))
|
(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
|
('electric-switch (list x y obj:electric-switch
|
||||||
(assq-ref properties 'target-x)
|
(assq-ref properties 'target-x)
|
||||||
(assq-ref properties 'target-y)))
|
(assq-ref properties 'target-y)))
|
||||||
|
|
Loading…
Add table
Reference in a new issue