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

Cheap trick to make logic gates enforce electron directionality.

Browse source
This commit is contained in:
David Thompson 2024-05-23 17:28:09 -04:00
parent 1b51dde9bc
commit 00df10dc12
1 changed files with 81 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

156
modules/game/actors.scm
View file

@ -28,6 +28,22 @@
('electron-head 'electron-tail)
('electron-tail 'copper)))
(define (electron-head-count neighbor-grid)
(define (check state)
(match state
('electron-head 1)
(_ 0)))
(match neighbor-grid
(#(a b c d '_ e f g h)
(+ (check a)
(check b)
(check c)
(check d)
(check e)
(check f)
(check g)
(check h)))))
(define* (^cell bcom #:optional val)
(case-lambda
(() val)
@ -44,8 +60,8 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info) #f)
(('update-wire-state grid-info) #f)
(('wire-state grid-info from from-x from-y) #f)
(('update-wire-state grid-info neighbor-grid) #f)
(('alive?) #t)
(('describe) `(exit ,position))
(('collide other offset grid-info) #f)))
@ -60,15 +76,15 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info)
(('wire-state grid-info from from-x from-y)
(match type
((or 'copper 'electron-head 'electron-tail)
type)
(_ #f)))
(('update-wire-state grid-info)
(('update-wire-state grid-info neighbor-grid)
(match type
((or 'copper 'electron-head 'electron-tail)
(let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y))
(let* ((neighbors (electron-head-count neighbor-grid))
(type (wireworld-next type neighbors)))
(bcom (^wall bcom x y type))))
(_ #f)))
@ -87,17 +103,17 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info)
(('wire-state grid-info from from-x from-y)
(match type
((or 'copper 'electron-head 'electron-tail)
type)
(_ #f)))
(('update-wire-state grid-info)
(('update-wire-state grid-info neighbor-grid)
(match type
((or 'copper 'electron-head 'electron-tail)
(match ($ position)
(#(x y z)
(let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y))
(let* ((neighbors (electron-head-count neighbor-grid))
(type (wireworld-next type neighbors)))
(bcom (^block bcom x y type))))))
(_ #f)))
@ -135,12 +151,12 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info)
(('wire-state grid-info from from-x from-y)
(match ($ timer)
(0 'electron-head)
(1 'electron-tail)
(_ 'copper)))
(('update-wire-state grid-info) #f)
(('update-wire-state grid-info neighbor-grid) #f)
(('alive?) #t)
(('describe) `(clock-emitter ,position))
(('collide other offset grid-info) #f)))
@ -168,13 +184,13 @@
(('deactivate grid-info)
($ on? #f)
($ grid-info 'append-event `(emitter-off ,x ,y)))
(('wire-state grid-info)
(('wire-state grid-info from from-x from-y)
(and ($ on?)
(match ($ timer)
(0 'electron-head)
(1 'electron-tail)
(_ 'copper))))
(('update-wire-state grid-info) #f)
(('update-wire-state grid-info neighbor-grid) #f)
(('alive?) #t)
(('on?) ($ on?))
(('describe) `(switched-emitter ,position ,($ on?)))
@ -207,8 +223,8 @@
(target
($ grid-info 'append-event `(floor-switch-off ,x ,y))
($ target 'deactivate grid-info)))))
(('wire-state grid-info) #f)
(('update-wire-state grid-info) #f)
(('wire-state grid-info from from-x from-y) #f)
(('update-wire-state grid-info neighbor-grid) #f)
(('alive?) #t)
(('describe) `(floor-switch ,position ,($ on?)))
(('collide other offset grid-info)
@ -230,8 +246,8 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info) #f)
(('update-wire-state grid-info)
(('wire-state grid-info from from-x from-y) #f)
(('update-wire-state grid-info neighbor-grid)
(if ($ on?)
(let ((t (1- ($ timer))))
($ timer t)
@ -242,7 +258,7 @@
(target
($ grid-info 'append-event `(electric-switch-off ,x ,y))
($ target 'deactivate grid-info)))))
(when (>= ($ grid-info 'wireworld-neighbor-count x y) 1)
(when (>= (electron-head-count neighbor-grid) 1)
($ on? #t)
($ timer 2)
(match (first-non-player-occupant grid-info target-x target-y)
@ -273,8 +289,8 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info) ($ state))
(('update-wire-state grid-info)
(('wire-state grid-info from from-x from-y) ($ state))
(('update-wire-state grid-info neighbor-grid)
(match ($ state)
('electron-head ($ state 'electron-tail))
('electron-tail ($ state 'copper))
@ -284,7 +300,7 @@
($ state 'electron-head)
($ electron? #f)
($ grid-info 'append-event `(receive-electron ,x ,y)))
(let ((neighbors ($ grid-info 'wireworld-neighbor-count x y)))
(let ((neighbors (electron-head-count neighbor-grid)))
(if (<= 1 neighbors 2)
(begin
($ state 'electron-head)
@ -307,8 +323,8 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info) #f)
(('update-wire-state grid-info) #f)
(('wire-state grid-info from from-x from-y) #f)
(('update-wire-state grid-info neighbor-grid) #f)
(('alive?) (not ($ picked-up?)))
(('describe) `(gem ,position))
(('collide other offset grid-info)
@ -325,8 +341,8 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info) #f)
(('update-wire-state grid-info) #f)
(('wire-state grid-info from from-x from-y) #f)
(('update-wire-state grid-info neighbor-grid) #f)
(('alive?) #t)
(('describe) `(ghost-gem ,position))
(('collide other offset grid-info) #f)))
@ -347,8 +363,8 @@
(('deactivate grid-info)
($ open? #f)
($ grid-info 'append-event `(gate-close ,x ,y)))
(('wire-state grid-info) #f)
(('update-wire-state grid-info) #f)
(('wire-state grid-info from from-x from-y) #f)
(('update-wire-state grid-info neighbor-grid) #f)
(('alive?) #t)
(('open?) ($ open?))
(('describe) `(gate ,position ,($ open?)))
@ -364,13 +380,26 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info) ($ state))
(('update-wire-state grid-info)
(('wire-state grid-info from from-x from-y)
;; We are compressing what would take many cells in the actual
;; Wireworld into a single tile. A naive approach to this would
;; send electrons flowing backwards through the logic gates. So,
;; need to play a trick to make enforce directionality. The
;; trick is that we know who is asking for our wire state. If
;; the object is opposes the direction we are pushing electrons,
;; then we tell them we're just copper. Otherwise, we reveal our
;; true state. Sneaky, sneaky.
(match direction
('left (if (> from-x x) 'copper ($ state)))
('right (if (< from-x x) 'copper ($ state)))
('up (if (> from-y y) 'copper ($ state)))
('down (if (< from-y y) 'copper ($ state)))))
(('update-wire-state grid-info neighbor-grid)
(match ($ state)
('electron-head ($ state 'electron-tail))
('electron-tail ($ state 'copper))
('copper
(update-wire-state state ($ grid-info 'wireworld-neighbor-grid x y)))))
(update-wire-state state neighbor-grid))))
(('alive?) #t)
(('describe) `(,name ,position ,direction ,($ state)))
(('collide other offset grid-info) #f)))
@ -626,7 +655,7 @@
(_ (lp rest)))))))))
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state grid-info) #f)
(('wire-state grid-info from from-x from-y) #f)
(('alive?) ($ alive?))
(('describe) `(player ,($ position), ($ alive?)))
(('collide other offset grid-info)
@ -692,62 +721,35 @@
(vector-set! grid (+ (* y width) x) val))
(define grid (make-grid '()))
(define wire-grid (make-grid #f))
(define (refresh-wire-grid)
(for-each-coord
(lambda (x y)
(let ((obj-cell (grid-ref grid x y))
(wire-cell (grid-ref wire-grid x y)))
(match ($ obj-cell)
(define (wire-state-at who who-x who-y target-x target-y)
(match ($ (grid-ref/wrap grid target-x target-y))
(() #f)
;; TODO: Handle tiles with many occupants. Might not be
;; necessary in practice. Actually this *WILL* cause
;; problems for electron warps, at least, since they are
;; invisible and the player can stand over them.
((refr . _)
($ wire-cell ($ refr 'wire-state grid-info))))))))
(define (wire-state-at x y)
($ (grid-ref/wrap wire-grid x y)))
(define (neighbor-count x y)
(define (check x y)
(match (wire-state-at x y)
('electron-head 1)
(_ 0)))
(+ (check (- x 1) (- y 1))
(check x (- y 1))
(check (+ x 1) (- y 1))
(check (- x 1) y)
(check (+ x 1) y)
(check (- x 1) (+ y 1))
(check x (+ y 1))
(check (+ x 1) (+ y 1))))
((obj . _)
($ obj 'wire-state grid-info who who-x who-y))))
;; flattened 3x3 grid of neighbor states. '_' used to mark the
;; center.
(define (neighbor-grid x y)
(vector (wire-state-at (- x 1) (- y 1))
(wire-state-at x (- y 1))
(wire-state-at (+ x 1) (- y 1))
(define (neighbor-grid obj)
(match ($ obj 'position)
(#(x y z)
(vector (wire-state-at obj x y (- x 1) (- y 1))
(wire-state-at obj x y x (- y 1))
(wire-state-at obj x y (+ x 1) (- y 1))
(wire-state-at (- x 1) y)
(wire-state-at obj x y (- x 1) y)
'_
(wire-state-at (+ x 1) y)
(wire-state-at obj x y (+ x 1) y)
(wire-state-at (- x 1) (+ y 1))
(wire-state-at x (+ y 1))
(wire-state-at (+ x 1) (+ y 1))))
(wire-state-at obj x y (- x 1) (+ y 1))
(wire-state-at obj x y x (+ y 1))
(wire-state-at obj x y (+ x 1) (+ y 1))))))
;; Read-only access to query the grid.
;; Read-only access to query the grid, but can write events.
(define (^grid-info bcom)
(match-lambda*
(('occupied? x y)
(not (null? ($ (grid-ref grid x y)))))
(('occupants x y)
($ (grid-ref grid x y)))
;; How many electron heads around (x, y)?
(('wireworld-neighbor-count x y)
(neighbor-count x y))
(('wireworld-neighbor-grid x y)
(neighbor-grid x y))
(('append-event event)
($ event-log 'append event))))
(define grid-info (spawn ^grid-info))
@ -827,10 +829,10 @@
;; Tick all the non-player objects.
(iter-objects tick-object)
;; Advance Wirewold simulation.
(refresh-wire-grid)
(for-each (lambda (obj)
($ obj 'update-wire-state grid-info))
($ objects))
(let ((neighbor-grids (map neighbor-grid ($ objects))))
(for-each (lambda (obj neighbor-grid)
($ obj 'update-wire-state grid-info neighbor-grid))
($ objects) neighbor-grids))
;; Run post-tick hooks.
($ player 'post-tick grid-info)
(iter-objects (lambda (obj) ($ obj 'post-tick grid-info)))))