(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)))