foss-mmo/modules/game/actors.scm

210 lines
6.2 KiB
Scheme
Raw Normal View History

(define-module (game actors)
#:use-module (goblins core)
#:use-module (ice-9 match)
#:export (^cell
^exit
^wall
^block
^clock-emitter
^player
^level))
(define* (^cell bcom #:optional val)
(case-lambda
(() val)
((new-val)
(bcom (^cell bcom new-val)))))
(define (^exit bcom)
(match-lambda*
(('tick) #f)
(('wire-state) #f)
(('set-wire-state) #f)
(('describe) '(exit))
(('collide) 'exit)))
(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) 'bump)))
(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) 'push)))
(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) 'bump)))
(define (^player bcom)
(match-lambda*
(('tick) #f)
(('wire-state) #f)
(('describe) '(player))))
(define (^level bcom width height)
(define player (spawn ^player))
;; TODO: Move this into the player actor.
(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)
('bump 'bump)
('exit
($ old-cell #f)
($ cell player)
($ player-coords (vector x y))
'exit)
('push
(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))
'push)
(_ #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))))
(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*))
(('set-object x y obj)
($ (grid-ref grid x y) obj))
;; TODO: Move to player actor
(('warp-player x y)
(warp-player x y))
(('move-player dir)
(define result
(match dir
('up (move-player 0 -1))
('down (move-player 0 1))
('left (move-player -1 0))
('right (move-player 1 0))))
(tick)
result)))