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
parent
7803eaba1c
commit
73ffad19f0
5 changed files with 219 additions and 38 deletions
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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"/>
|
||||
|
|
|
|||
|
|
@ -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"/>
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue