SuperKamiGuru/foss-mmo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement orientation for logic gates

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

200
modules/game/actors.scm
View file

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

10
modules/game/level.scm
View file

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

6
modules/game/levels/level-3.tmx
View file

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

18
modules/game/levels/level-4.tmx
View file

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

23
scripts/compile-map.scm
View file

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