857 lines
28 KiB
Scheme
857 lines
28 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 (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)
|
|
((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 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)))
|
|
|
|
;; 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 from from-x from-y)
|
|
(match type
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
type)
|
|
(_ #f)))
|
|
(('update-wire-state grid-info neighbor-grid)
|
|
(match type
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
(let* ((neighbors (electron-head-count neighbor-grid))
|
|
(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 from from-x from-y)
|
|
(match type
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
type)
|
|
(_ #f)))
|
|
(('update-wire-state grid-info neighbor-grid)
|
|
(match type
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
(match ($ position)
|
|
(#(x y z)
|
|
(let* ((neighbors (electron-head-count neighbor-grid))
|
|
(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)
|
|
(match ($ grid-info 'dimensions)
|
|
(#(w h)
|
|
(let ((x (modulo (+ x dx) w))
|
|
(y (modulo (+ y dy) h)))
|
|
(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)
|
|
(let ((t (modulo (+ ($ timer) 1) interval)))
|
|
($ timer t)
|
|
(when (= t 0)
|
|
($ grid-info 'append-event `(emit ,x ,y)))))
|
|
(('post-tick grid-info) #f)
|
|
(('enter obj grid-info) #f)
|
|
(('exit obj grid-info) #f)
|
|
(('wire-state grid-info from from-x from-y)
|
|
(match ($ timer)
|
|
(0 'electron-head)
|
|
(1 'electron-tail)
|
|
(_ 'copper)))
|
|
(('update-wire-state grid-info neighbor-grid) #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?)
|
|
(let ((t (modulo (+ ($ timer) 1) interval)))
|
|
($ timer t)
|
|
(when (= t 0)
|
|
($ grid-info 'append-event `(emit ,x ,y))))))
|
|
(('post-tick grid-info) #f)
|
|
(('enter obj grid-info) #f)
|
|
(('exit obj grid-info) #f)
|
|
(('activate grid-info)
|
|
($ on? #t)
|
|
($ timer -1)
|
|
($ grid-info 'append-event `(emitter-on ,x ,y)))
|
|
(('deactivate grid-info)
|
|
($ on? #f)
|
|
($ grid-info 'append-event `(emitter-off ,x ,y)))
|
|
(('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 neighbor-grid) #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 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)
|
|
($ 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 from from-x from-y) #f)
|
|
(('update-wire-state grid-info neighbor-grid)
|
|
(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 (>= (electron-head-count neighbor-grid) 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 from from-x from-y) ($ state))
|
|
(('update-wire-state grid-info neighbor-grid)
|
|
(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 (electron-head-count neighbor-grid)))
|
|
(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 from from-x from-y) #f)
|
|
(('update-wire-state grid-info neighbor-grid) #f)
|
|
(('alive?) (pk 'gem-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 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)))
|
|
|
|
(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 from from-x from-y) #f)
|
|
(('update-wire-state grid-info neighbor-grid) #f)
|
|
(('alive?) #t)
|
|
(('open?) ($ open?))
|
|
(('describe) `(gate ,position ,($ open?)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^logic-gate bcom x y name direction update-wire-state)
|
|
(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 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 neighbor-grid))))
|
|
(('alive?) #t)
|
|
(('describe) `(,name ,position ,direction ,($ state)))
|
|
(('collide other offset grid-info) #f)))
|
|
|
|
(define (^and-gate bcom x y direction)
|
|
(define (update-wire-state state neighbor-grid)
|
|
(match direction
|
|
('right
|
|
(match neighbor-grid
|
|
(#('electron-head #f #f
|
|
#f _ 'copper
|
|
'electron-head #f #f)
|
|
($ state 'electron-head))
|
|
(_ ($ state 'copper))))
|
|
('left
|
|
(match neighbor-grid
|
|
(#(#f #f 'electron-head
|
|
'copper _ #f
|
|
#f #f 'electron-head)
|
|
($ state 'electron-head))
|
|
(_ ($ state 'copper))))
|
|
('up
|
|
(match neighbor-grid
|
|
(#(#f 'copper #f
|
|
#f _ #f
|
|
'electron-head #f 'electron-head)
|
|
($ state 'electron-head))
|
|
(_ ($ state 'copper))))
|
|
('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 direction update-wire-state))
|
|
|
|
(define (^xor-gate bcom x y direction)
|
|
(define (update-wire-state state neighbor-grid)
|
|
(match direction
|
|
('right
|
|
(match neighbor-grid
|
|
(#('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))))
|
|
('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))))
|
|
('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))))
|
|
('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 direction update-wire-state))
|
|
|
|
(define (^or-gate bcom x y direction)
|
|
(define (update-wire-state state neighbor-grid)
|
|
(match direction
|
|
('right
|
|
(match neighbor-grid
|
|
(#('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))))
|
|
('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))))
|
|
('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))))
|
|
('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 direction update-wire-state))
|
|
|
|
(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)
|
|
(#(0 0) (values))
|
|
(#(dx dy)
|
|
(match ($ grid-info 'dimensions)
|
|
(#(w h)
|
|
($ position (vector (modulo (+ x dx) w) (modulo (+ y dy) h) 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 from from-x from-y) #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-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 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 obj x y (- x 1) y)
|
|
'_
|
|
(wire-state-at obj x y (+ x 1) y)
|
|
|
|
(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, but can write events.
|
|
(define (^grid-info bcom)
|
|
(match-lambda*
|
|
(('dimensions) (vector width height))
|
|
(('occupied? x y) (not (null? ($ (grid-ref/wrap grid x y)))))
|
|
(('occupants x y) ($ (grid-ref/wrap 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.
|
|
(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)))))
|
|
|
|
(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))))
|