731 lines
24 KiB
Scheme
731 lines
24 KiB
Scheme
(define-module (game actors)
|
|
#:use-module (goblins core)
|
|
#:use-module (ice-9 match)
|
|
#:export (^cell
|
|
^exit
|
|
^wall
|
|
^block
|
|
^clock-emitter
|
|
^switched-emitter
|
|
^floor-switch
|
|
^gate
|
|
^gem
|
|
^ghost-gem
|
|
^and-gate
|
|
^xor-gate
|
|
^or-gate
|
|
^electric-switch
|
|
^electron-warp
|
|
^player
|
|
^level))
|
|
|
|
;; The default wireworld rules. Actors are free to use this or
|
|
;; implement their own rule for themselves.
|
|
(define (wireworld-next wire-state neighbors)
|
|
(match wire-state
|
|
(#f #f)
|
|
('copper (if (<= 1 neighbors 2) 'electron-head 'copper))
|
|
('electron-head 'electron-tail)
|
|
('electron-tail 'copper)))
|
|
|
|
(define* (^cell bcom #:optional val)
|
|
(case-lambda
|
|
(() val)
|
|
((new-val)
|
|
(bcom (^cell bcom new-val)))))
|
|
|
|
;; TODO: Port actor-lib methods and use it.
|
|
(define (^exit bcom x y)
|
|
(define position (vector x y 1))
|
|
(match-lambda*
|
|
(('type) 'exit)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('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)
|
|
(('alive?) #t)
|
|
(('describe) `(exit ,position))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
;; TODO: Maybe make separate actors for conductive vs. inert walls.
|
|
(define (^wall bcom x y type)
|
|
(define position (vector x y 1))
|
|
(match-lambda*
|
|
(('type) 'wall)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('post-tick grid-info) #f)
|
|
(('enter obj grid-info) #f)
|
|
(('exit obj grid-info) #f)
|
|
(('wire-state grid-info)
|
|
(match type
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
type)
|
|
(_ #f)))
|
|
(('update-wire-state grid-info)
|
|
(match type
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
(let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y))
|
|
(type (wireworld-next type neighbors)))
|
|
(bcom (^wall bcom x y type))))
|
|
(_ #f)))
|
|
(('alive?) #t)
|
|
(('describe) `(wall ,position ,type))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
;; TODO: Maybe make separate actors for conductive vs. inert blocks.
|
|
(define (^block bcom x y type)
|
|
(define position (spawn ^cell (vector x y 1)))
|
|
(define pushed? (spawn ^cell))
|
|
(match-lambda*
|
|
(('type) 'block)
|
|
(('position) ($ position))
|
|
(('tick grid-info) ($ pushed? #f))
|
|
(('post-tick grid-info) #f)
|
|
(('enter obj grid-info) #f)
|
|
(('exit obj grid-info) #f)
|
|
(('wire-state grid-info)
|
|
(match type
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
type)
|
|
(_ #f)))
|
|
(('update-wire-state grid-info)
|
|
(match type
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
(match ($ position)
|
|
(#(x y z)
|
|
(let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y))
|
|
(type (wireworld-next type neighbors)))
|
|
(bcom (^block bcom x y type))))))
|
|
(_ #f)))
|
|
(('alive?) #t)
|
|
(('describe) `(block ,($ position) ,type))
|
|
(('collide other offset grid-info)
|
|
(when (eq? ($ other 'type) 'player)
|
|
(match ($ position)
|
|
(#(x y z)
|
|
(match offset
|
|
(#(dx dy)
|
|
(let ((x (+ x dx))
|
|
(y (+ y dy)))
|
|
(let ((occupant-types
|
|
(map (lambda (obj) ($ obj 'type))
|
|
($ grid-info 'occupants x y))))
|
|
(match occupant-types
|
|
((or () ('switch))
|
|
($ pushed? #t)
|
|
($ position (vector x y z)))
|
|
(_ #f))))))))))
|
|
(('pushed?) ($ pushed?))))
|
|
|
|
(define (^clock-emitter bcom x y interval)
|
|
(define timer (spawn ^cell -1))
|
|
(define position (vector x y 0))
|
|
(match-lambda*
|
|
(('type) 'emitter)
|
|
(('position) position)
|
|
(('tick grid-info) ($ timer (+ ($ timer) 1)))
|
|
(('post-tick grid-info) #f)
|
|
(('enter obj grid-info) #f)
|
|
(('exit obj grid-info) #f)
|
|
(('wire-state grid-info)
|
|
(let ((t ($ timer)))
|
|
(cond
|
|
((= (modulo t interval) 0)
|
|
($ grid-info 'append-event `(emit ,x ,y))
|
|
'electron-head)
|
|
((= (modulo t interval) 1)
|
|
'electron-tail)
|
|
(else
|
|
'copper))))
|
|
(('update-wire-state grid-info) #f)
|
|
(('alive?) #t)
|
|
(('describe) `(clock-emitter ,position))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^switched-emitter bcom x y interval)
|
|
(define timer (spawn ^cell -1))
|
|
(define on? (spawn ^cell))
|
|
(define position (vector x y 0))
|
|
(match-lambda*
|
|
(('type) 'switched-emitter)
|
|
(('position) position)
|
|
(('tick grid-info)
|
|
(when ($ on?)
|
|
($ timer (+ ($ timer) 1))))
|
|
(('post-tick grid-info) #f)
|
|
(('enter obj grid-info) #f)
|
|
(('exit obj grid-info) #f)
|
|
(('activate grid-info)
|
|
($ on? #t)
|
|
($ timer 0))
|
|
(('deactivate grid-info) ($ on? #f))
|
|
(('wire-state grid-info)
|
|
(when ($ on?)
|
|
(let ((t ($ timer)))
|
|
(cond
|
|
((= (modulo t interval) 0)
|
|
'electron-head)
|
|
((= (modulo t interval) 1)
|
|
'electron-tail)
|
|
(else
|
|
'copper)))))
|
|
(('update-wire-state grid-info) #f)
|
|
(('alive?) #t)
|
|
(('on?) ($ on?))
|
|
(('describe) `(switched-emitter ,position ,($ on?)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (first-non-player-occupant grid-info x y)
|
|
(let lp ((objs ($ grid-info 'occupants x y)))
|
|
(match objs
|
|
(() #f)
|
|
((obj . rest)
|
|
(if (eq? ($ obj 'type) 'player)
|
|
(lp rest)
|
|
obj)))))
|
|
|
|
(define (^floor-switch bcom x y target-x target-y)
|
|
(define position (vector x y 0))
|
|
(define on? (spawn ^cell))
|
|
(match-lambda*
|
|
(('type) 'switch)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('post-tick grid-info) #f)
|
|
(('enter obj grid-info)
|
|
($ on? #t))
|
|
(('exit obj grid-info)
|
|
(when (= (length ($ grid-info 'occupants x y)) 1)
|
|
($ on? #f)
|
|
(match (first-non-player-occupant grid-info target-x target-y)
|
|
(#f (pk "no switch target!"))
|
|
(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)
|
|
(('alive?) #t)
|
|
(('describe) `(floor-switch ,position ,($ on?)))
|
|
(('collide other offset grid-info)
|
|
($ on? #t)
|
|
(match (first-non-player-occupant grid-info target-x target-y)
|
|
(#f (pk "no switch target!"))
|
|
(target
|
|
($ grid-info 'append-event `(floor-switch-on ,x ,y))
|
|
($ target 'activate grid-info))))))
|
|
|
|
(define (^electric-switch bcom x y target-x target-y)
|
|
(define position (vector x y 0))
|
|
(define on? (spawn ^cell))
|
|
(define timer (spawn ^cell))
|
|
(match-lambda*
|
|
(('type) 'electric-switch)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('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)
|
|
(if ($ on?)
|
|
(let ((t (1- ($ timer))))
|
|
($ timer t)
|
|
(when (= t 0)
|
|
($ on? #f)
|
|
(match (first-non-player-occupant grid-info target-x target-y)
|
|
(#f (pk "no switch target!"))
|
|
(target
|
|
($ grid-info 'append-event `(electric-switch-off ,x ,y))
|
|
($ target 'deactivate grid-info)))))
|
|
(when (>= ($ grid-info 'wireworld-neighbor-count x y) 1)
|
|
($ on? #t)
|
|
($ timer 2)
|
|
(match (first-non-player-occupant grid-info target-x target-y)
|
|
(#f (pk "no switch target!"))
|
|
(target
|
|
($ grid-info 'append-event `(electric-switch-on ,x ,y))
|
|
($ target 'activate grid-info))))))
|
|
(('alive?) #t)
|
|
(('describe) `(electric-switch ,position ,($ on?)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^electron-warp bcom x y target-x target-y)
|
|
(define position (vector x y 0))
|
|
(define state (spawn ^cell 'copper))
|
|
(define electron? (spawn ^cell))
|
|
(define (find-receiver grid-info)
|
|
(let lp ((objs ($ grid-info 'occupants target-x target-y)))
|
|
(match objs
|
|
(() (error "no electron receiver at tile" target-x target-y))
|
|
((obj . rest)
|
|
(if (eq? ($ obj 'type) 'electron-warp)
|
|
obj
|
|
(lp rest))))))
|
|
(match-lambda*
|
|
(('type) 'electron-warp)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('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)
|
|
(match ($ state)
|
|
('electron-head ($ state 'electron-tail))
|
|
('electron-tail ($ state 'copper))
|
|
('copper
|
|
(if ($ electron?)
|
|
(begin
|
|
($ state 'electron-head)
|
|
($ electron? #f)
|
|
($ grid-info 'append-event `(receive-electron ,x ,y)))
|
|
(let ((neighbors ($ grid-info 'wireworld-neighbor-count x y)))
|
|
(if (<= 1 neighbors 2)
|
|
(begin
|
|
($ state 'electron-head)
|
|
;; Forward an electron head to the receiver.
|
|
($ (find-receiver grid-info) 'give-electron)
|
|
($ grid-info 'append-event `(send-electron ,x ,y)))
|
|
($ state 'copper)))))))
|
|
(('give-electron) ($ electron? #t))
|
|
(('alive?) #t)
|
|
(('describe) `(electron-warp ,position ,($ state)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^gem bcom x y)
|
|
(define position (vector x y 1))
|
|
(define picked-up? (spawn ^cell))
|
|
(match-lambda*
|
|
(('type) 'gem)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('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)
|
|
(('alive?) (not ($ picked-up?)))
|
|
(('describe) `(gem ,position))
|
|
(('collide other offset grid-info)
|
|
(when (eq? ($ other 'type) 'player)
|
|
($ picked-up? #t)
|
|
($ grid-info 'append-event `(pickup ,x ,y))))))
|
|
|
|
(define (^ghost-gem bcom x y)
|
|
(define position (vector x y 1))
|
|
(match-lambda*
|
|
(('type) 'ghost-gem)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('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)
|
|
(('alive?) #t)
|
|
(('describe) `(ghost-gem ,position))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^gate bcom x y)
|
|
(define position (vector x y 1))
|
|
(define open? (spawn ^cell))
|
|
(match-lambda*
|
|
(('type) 'gate)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('post-tick grid-info) #f)
|
|
(('enter obj grid-info) #f)
|
|
(('exit obj grid-info) #f)
|
|
(('activate grid-info)
|
|
($ open? #t)
|
|
($ grid-info 'append-event `(gate-open ,x ,y)))
|
|
(('deactivate grid-info)
|
|
($ open? #f)
|
|
($ grid-info 'append-event `(gate-close ,x ,y)))
|
|
(('wire-state grid-info) #f)
|
|
(('update-wire-state grid-info) #f)
|
|
(('alive?) #t)
|
|
(('open?) ($ open?))
|
|
(('describe) `(gate ,position ,($ open?)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^and-gate bcom x y)
|
|
(define position (vector x y 0))
|
|
(define state (spawn ^cell 'copper))
|
|
(match-lambda*
|
|
(('type) 'emitter)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('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)
|
|
(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)
|
|
(#('electron-head #f #f
|
|
#f _ 'copper
|
|
'electron-head #f #f)
|
|
($ state 'electron-head))
|
|
(_ ($ state 'copper))))))
|
|
(('alive?) #t)
|
|
(('describe) `(and-gate ,position ,($ state)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^xor-gate bcom x y)
|
|
(define position (vector x y 0))
|
|
(define state (spawn ^cell 'copper))
|
|
(match-lambda*
|
|
(('type) 'emitter)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('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)
|
|
(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)
|
|
(#('electron-head #f #f
|
|
#f _ 'copper
|
|
#f #f #f)
|
|
($ state 'electron-head))
|
|
(#('electron-head #f #f
|
|
#f _ 'copper
|
|
'copper #f #f)
|
|
($ state 'electron-head))
|
|
(#(#f #f #f
|
|
#f _ 'copper
|
|
'electron-head #f #f)
|
|
($ state 'electron-head))
|
|
(#('copper #f #f
|
|
#f _ 'copper
|
|
'electron-head #f #f)
|
|
($ state 'electron-head))
|
|
(_ ($ state 'copper))))))
|
|
(('alive?) #t)
|
|
(('describe) `(xor-gate ,position ,($ state)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^or-gate bcom x y)
|
|
(define position (vector x y 0))
|
|
(define state (spawn ^cell 'copper))
|
|
(match-lambda*
|
|
(('type) 'emitter)
|
|
(('position) position)
|
|
(('tick grid-info) #f)
|
|
(('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)
|
|
(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)
|
|
(#('electron-head #f #f
|
|
#f _ 'copper
|
|
#f #f #f)
|
|
($ state 'electron-head))
|
|
(#('electron-head #f #f
|
|
#f _ 'copper
|
|
'copper #f #f)
|
|
($ state 'electron-head))
|
|
(#(#f #f #f
|
|
#f _ 'copper
|
|
'electron-head #f #f)
|
|
($ state 'electron-head))
|
|
(#('copper #f #f
|
|
#f _ 'copper
|
|
'electron-head #f #f)
|
|
($ state 'electron-head))
|
|
(#('electron-head #f #f
|
|
#f _ 'copper
|
|
'electron-head #f #f)
|
|
($ state 'electron-head))
|
|
(_ ($ state 'copper))))))
|
|
(('alive?) #t)
|
|
(('describe) `(or-gate ,position ,($ state)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^player bcom x y)
|
|
(define position (spawn ^cell (vector x y 2)))
|
|
(define velocity (spawn ^cell #(0 0)))
|
|
(define alive? (spawn ^cell #t))
|
|
(match-lambda*
|
|
(('type) 'player)
|
|
(('position) ($ position))
|
|
(('move dir)
|
|
($ velocity
|
|
(match dir
|
|
('left #(-1 0))
|
|
('right #(1 0))
|
|
('up #(0 -1))
|
|
('down #(0 1))
|
|
(_ (error "invalid direction" dir)))))
|
|
(('tick grid-info)
|
|
(match ($ position)
|
|
(#(x y z)
|
|
(match ($ velocity)
|
|
(#(dx dy)
|
|
($ position (vector (+ x dx) (+ y dy) z))
|
|
($ velocity #(0 0)))))))
|
|
(('post-tick grid-info)
|
|
;; Search for objects that were fine to step onto last turn, but
|
|
;; have become deadly this turn.
|
|
(match ($ position)
|
|
(#(x y z)
|
|
(let lp ((objs ($ grid-info 'occupants x y)))
|
|
(match objs
|
|
(() #f)
|
|
((obj . rest)
|
|
(match ($ obj 'type)
|
|
('gate
|
|
;; Ouch, a gate closed on the player!
|
|
(unless ($ obj 'open?)
|
|
($ alive? #f)
|
|
($ grid-info 'append-event `(player-death ,x ,y))))
|
|
(_ (lp rest)))))))))
|
|
(('enter obj grid-info) #f)
|
|
(('exit obj grid-info) #f)
|
|
(('wire-state grid-info) #f)
|
|
(('alive?) ($ alive?))
|
|
(('describe) `(player ,($ position), ($ alive?)))
|
|
(('collide other offset grid-info)
|
|
(match ($ position)
|
|
(#(x y z)
|
|
(define (reverse-move)
|
|
(match offset
|
|
(#(dx dy)
|
|
($ position (vector (- x dx) (- y dy) z)))))
|
|
(match ($ other 'type)
|
|
('exit
|
|
($ grid-info 'append-event `(exit ,x ,y)))
|
|
('block
|
|
(if ($ other 'pushed?)
|
|
($ grid-info 'append-event `(push ,x ,y))
|
|
(begin
|
|
(reverse-move)
|
|
($ grid-info 'append-event `(bump ,x ,y)))))
|
|
((or 'gem 'switch 'ghost-gem) #t)
|
|
('gate
|
|
(unless ($ other 'open?)
|
|
(reverse-move)
|
|
($ grid-info 'append-event `(bump ,x ,y))))
|
|
(_
|
|
(reverse-move)
|
|
($ grid-info 'append-event `(bump ,x ,y)))))))))
|
|
|
|
(define (^event-log bcom)
|
|
(define events (spawn ^cell '()))
|
|
(match-lambda*
|
|
(('append event)
|
|
($ events (cons event ($ events))))
|
|
(('flush)
|
|
(let ((result (reverse ($ events))))
|
|
($ events '())
|
|
result))))
|
|
|
|
(define (^level bcom width height)
|
|
(define player (spawn ^cell))
|
|
(define objects (spawn ^cell '()))
|
|
(define event-log (spawn ^event-log))
|
|
|
|
;; Spatial partition
|
|
(define (for-each-coord proc)
|
|
(let y-loop ((y 0))
|
|
(when (< y height)
|
|
(let x-loop ((x 0))
|
|
(when (< x width)
|
|
(proc x y)
|
|
(x-loop (1+ x))))
|
|
(y-loop (1+ y)))))
|
|
(define (make-grid init)
|
|
(let ((grid (make-vector (* width height))))
|
|
(for-each-coord
|
|
(lambda (x y)
|
|
(grid-set! grid x y (spawn ^cell init))))
|
|
grid))
|
|
(define (grid-ref grid x y)
|
|
(vector-ref grid (+ (* y width) x)))
|
|
(define (grid-ref/wrap grid x y)
|
|
(grid-ref grid (modulo x width) (modulo y height)))
|
|
(define (grid-set! grid x y val)
|
|
(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))))
|
|
;; 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))
|
|
|
|
(wire-state-at (- x 1) y)
|
|
'_
|
|
(wire-state-at (+ x 1) y)
|
|
|
|
(wire-state-at (- x 1) (+ y 1))
|
|
(wire-state-at x (+ y 1))
|
|
(wire-state-at (+ x 1) (+ y 1))))
|
|
|
|
;; Read-only access to query the grid.
|
|
(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))
|
|
|
|
(define (delq item lst)
|
|
(let lp ((lst lst))
|
|
(match lst
|
|
(() '())
|
|
((head . tail)
|
|
(if (eq? item head)
|
|
tail
|
|
(cons head (lp tail)))))))
|
|
(define (maybe-update-grid obj prev-pos resolved-pos)
|
|
(unless (equal? prev-pos resolved-pos)
|
|
(match prev-pos
|
|
(#(x y _)
|
|
(let* ((cell (grid-ref grid x y))
|
|
(remaining (delq obj ($ cell))))
|
|
($ cell remaining)
|
|
(for-each (lambda (other)
|
|
($ other 'exit obj grid-info))
|
|
remaining))))
|
|
(match resolved-pos
|
|
(#(x y _)
|
|
(let* ((cell (grid-ref grid x y))
|
|
(occupants ($ cell)))
|
|
($ cell (cons obj occupants))
|
|
(for-each (lambda (other)
|
|
($ other 'enter obj grid-info))
|
|
occupants))))))
|
|
(define (collide obj pos prev-pos)
|
|
(match pos
|
|
(#(x y _)
|
|
(let lp ((objects ($ (grid-ref grid x y))))
|
|
(match objects
|
|
(() (maybe-update-grid obj prev-pos ($ obj 'position)))
|
|
((other . rest)
|
|
(if (eq? obj other)
|
|
(lp rest)
|
|
(let ((other-prev-pos ($ other 'position)))
|
|
(match prev-pos
|
|
(#(prev-x prev-y _)
|
|
(let ((offset (vector (- x prev-x) (- y prev-y))))
|
|
(pk 'collision! ($ obj 'type) ($ other 'type))
|
|
($ other 'collide obj offset grid-info)
|
|
($ obj 'collide other offset grid-info)
|
|
;; If collision resolution displaced the other
|
|
;; object, then recur and check collision for
|
|
;; it.
|
|
(let ((other-pos ($ other 'position)))
|
|
(unless (equal? other-pos other-prev-pos)
|
|
(collide other other-pos other-prev-pos)))
|
|
(lp rest))))))))))))
|
|
(define (iter-objects proc)
|
|
($ objects
|
|
(let lp ((objs ($ objects)))
|
|
(match objs
|
|
(() '())
|
|
((obj . rest)
|
|
(proc obj)
|
|
;; Cull dead objects.
|
|
(if ($ obj 'alive?)
|
|
(cons obj (lp rest))
|
|
(lp rest)))))))
|
|
(define (tick-object obj)
|
|
(let ((prev-pos ($ obj 'position)))
|
|
($ obj 'tick grid-info)
|
|
;; Only check collisions for movable objects.
|
|
(let ((desired-pos ($ obj 'position)))
|
|
(unless (equal? prev-pos desired-pos)
|
|
(collide obj desired-pos prev-pos)))))
|
|
(define (tick)
|
|
(let ((player ($ player)))
|
|
;; Player goes first.
|
|
(when ($ player 'alive?)
|
|
(tick-object player))
|
|
;; 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))
|
|
;; Run post-tick hooks.
|
|
($ player 'post-tick grid-info)
|
|
(iter-objects (lambda (obj) ($ obj 'post-tick grid-info)))))
|
|
|
|
(match-lambda*
|
|
(('tick) (tick))
|
|
(('describe)
|
|
(cons ($ ($ player) 'describe)
|
|
(map (lambda (obj) ($ obj 'describe)) ($ objects))))
|
|
(('add-object obj)
|
|
(if (eq? ($ obj 'type) 'player)
|
|
($ player obj)
|
|
($ objects (cons obj ($ objects))))
|
|
(match ($ obj 'position)
|
|
(#(x y _)
|
|
(let ((cell (grid-ref grid x y)))
|
|
($ cell (cons obj ($ cell)))))))
|
|
(('flush-events)
|
|
($ event-log 'flush))))
|