diff --git a/modules/game/actors.scm b/modules/game/actors.scm index 2136bd2..141584e 100644 --- a/modules/game/actors.scm +++ b/modules/game/actors.scm @@ -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) - (() #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)))) + (define (wire-state-at who who-x who-y target-x target-y) + (match ($ (grid-ref/wrap grid target-x target-y)) + (() #f) + ((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 (+ x 1) y) + (wire-state-at obj x y (- 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)))))