212 lines
6.6 KiB
Scheme
212 lines
6.6 KiB
Scheme
![]() |
(define-module (game actors)
|
||
|
#:use-module (dom canvas)
|
||
|
#:use-module (goblins core)
|
||
|
#:use-module (ice-9 match)
|
||
|
#:export (^cell
|
||
|
^level))
|
||
|
|
||
|
;; ^wall
|
||
|
;; ^wire
|
||
|
;; ^electron-head
|
||
|
;; ^electron-tail
|
||
|
|
||
|
(define* (^cell bcom #:optional val)
|
||
|
(case-lambda
|
||
|
(() val)
|
||
|
((new-val)
|
||
|
(bcom (^cell bcom new-val)))))
|
||
|
|
||
|
(define (^wall bcom type)
|
||
|
(match-lambda*
|
||
|
(('tick) #f)
|
||
|
(('wire-state)
|
||
|
(match type
|
||
|
((or 'copper 'electron-head 'electron-tail)
|
||
|
type)
|
||
|
(_ #f)))
|
||
|
(('set-wire-state type)
|
||
|
(bcom (^wall bcom type)))
|
||
|
(('describe) `(wall ,type))
|
||
|
(('collide) 'stop)))
|
||
|
|
||
|
(define (^block bcom type)
|
||
|
(match-lambda*
|
||
|
(('tick) #f)
|
||
|
(('wire-state)
|
||
|
(match type
|
||
|
((or 'copper 'electron-head 'electron-tail)
|
||
|
type)
|
||
|
(_ #f)))
|
||
|
(('set-wire-state type)
|
||
|
(bcom (^block bcom type)))
|
||
|
(('describe) `(block ,type))
|
||
|
(('collide) 'displace)))
|
||
|
|
||
|
(define (^clock-emitter bcom interval)
|
||
|
(define timer (spawn ^cell 0))
|
||
|
(match-lambda*
|
||
|
(('tick) ($ timer (+ ($ timer) 1)))
|
||
|
(('wire-state)
|
||
|
(let ((t ($ timer)))
|
||
|
(cond
|
||
|
((= (modulo t interval) 0)
|
||
|
'electron-head)
|
||
|
((= (modulo t interval) 1)
|
||
|
'electron-tail)
|
||
|
(else
|
||
|
'copper))))
|
||
|
(('set-wire-state type) #f)
|
||
|
(('describe) '(clock-emitter))
|
||
|
(('collide) 'stop)))
|
||
|
|
||
|
(define (^player bcom)
|
||
|
(match-lambda*
|
||
|
(('tick) #f)
|
||
|
(('wire-state) #f)
|
||
|
(('describe) '(player))))
|
||
|
|
||
|
(define (^level bcom width height)
|
||
|
(define player (spawn ^player))
|
||
|
(define player-coords (spawn ^cell))
|
||
|
(define (make-grid)
|
||
|
(make-vector (* width height)))
|
||
|
(define grid (make-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 (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 (wrap-x x)
|
||
|
(modulo x width))
|
||
|
(define (wrap-y y)
|
||
|
(modulo y height))
|
||
|
;; Assumes that dx/dy are in the range [0,1].
|
||
|
(define (move-player dx dy)
|
||
|
(match ($ player-coords)
|
||
|
(#(old-x old-y)
|
||
|
(let* ((x (wrap-x (+ old-x dx)))
|
||
|
(y (wrap-y (+ old-y dy)))
|
||
|
(old-cell (grid-ref grid old-x old-y))
|
||
|
(cell (grid-ref grid x y)))
|
||
|
(match ($ cell)
|
||
|
(#f
|
||
|
($ old-cell #f)
|
||
|
($ cell player)
|
||
|
($ player-coords (vector x y)))
|
||
|
(occupant
|
||
|
(match ($ occupant 'collide)
|
||
|
('stop #f)
|
||
|
('displace
|
||
|
(let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy)))))
|
||
|
(match ($ next-cell)
|
||
|
(#f
|
||
|
($ next-cell ($ cell))
|
||
|
($ cell player)
|
||
|
($ old-cell #f)
|
||
|
($ player-coords (vector x y)))
|
||
|
(_ #f)))))))))))
|
||
|
(define (warp-player x y)
|
||
|
($ (grid-ref grid x y) player)
|
||
|
(match ($ player-coords)
|
||
|
(#f
|
||
|
($ player-coords (vector x y)))
|
||
|
(#(old-x old-y)
|
||
|
($ player-coords (vector x y))
|
||
|
($ (grid-ref grid old-x old-y) #f))))
|
||
|
(define (tick)
|
||
|
(define (neighbors x y)
|
||
|
(define (check x y)
|
||
|
(match ($ (grid-ref/wrap grid x y))
|
||
|
(#f 0)
|
||
|
(refr
|
||
|
(match ($ refr 'wire-state)
|
||
|
('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 1))
|
||
|
(check x (+ y 1))
|
||
|
(check (- x 1) (+ y 1))
|
||
|
(check (- x 1) y)))
|
||
|
(for-each (match-lambda
|
||
|
((refr . wire-state)
|
||
|
($ refr 'set-wire-state wire-state)))
|
||
|
(let y-loop ((y 0) (updates '()))
|
||
|
(if (< y height)
|
||
|
(y-loop (1+ y)
|
||
|
(let x-loop ((x 0) (updates updates))
|
||
|
(if (< x width)
|
||
|
(match ($ (grid-ref grid x y))
|
||
|
(#f (x-loop (1+ x) updates))
|
||
|
(refr
|
||
|
($ refr 'tick)
|
||
|
(match ($ refr 'wire-state)
|
||
|
(#f (x-loop (1+ x) updates))
|
||
|
('copper
|
||
|
(if (<= 1 (neighbors x y) 2)
|
||
|
(x-loop (1+ x) (cons `(,refr . electron-head) updates))
|
||
|
(x-loop (1+ x) updates)))
|
||
|
('electron-head
|
||
|
(x-loop (1+ x) (cons `(,refr . electron-tail) updates)))
|
||
|
('electron-tail
|
||
|
(x-loop (1+ x) (cons `(,refr . copper) updates))))))
|
||
|
updates)))
|
||
|
updates))))
|
||
|
|
||
|
;; Initialize grid cells
|
||
|
(for-each-coord
|
||
|
(lambda (x y)
|
||
|
(grid-set! grid x y (spawn ^cell))))
|
||
|
|
||
|
;; TODO: actually write levels
|
||
|
(warp-player 10 8)
|
||
|
($ (grid-ref grid 4 4) (spawn ^wall 'brick))
|
||
|
|
||
|
($ (grid-ref grid 4 3) (spawn ^clock-emitter 3))
|
||
|
($ (grid-ref grid 5 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 6 4) (spawn ^block 'copper))
|
||
|
($ (grid-ref grid 7 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 8 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 9 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 10 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 11 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 12 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 13 2) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 13 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 13 4) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 14 2) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 14 4) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 15 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 16 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 17 3) (spawn ^wall 'copper))
|
||
|
($ (grid-ref grid 18 3) (spawn ^wall 'copper))
|
||
|
|
||
|
(match-lambda*
|
||
|
(('describe)
|
||
|
(let ((grid* (make-grid)))
|
||
|
(for-each-coord
|
||
|
(lambda (x y)
|
||
|
(grid-set! grid* x y
|
||
|
(match ($ (grid-ref grid x y))
|
||
|
(#f #f)
|
||
|
(refr ($ refr 'describe))))))
|
||
|
grid*))
|
||
|
(('move-player dir)
|
||
|
(match dir
|
||
|
('up (move-player 0 -1))
|
||
|
('down (move-player 0 1))
|
||
|
('left (move-player -1 0))
|
||
|
('right (move-player 1 0)))
|
||
|
(tick))))
|