(define-module (game actors) #:use-module (goblins core) #:use-module (hoot bytevectors) #:use-module (ice-9 match) #:export (^cell ^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) 'goal))) (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 objects) (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) ('bump 'bump) ('goal (pk 'GOAL)) ('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)))) ;; TODO: actually write levels (warp-player 10 8) ;; Parsed packed object data and spawn objects. (let ((len (bytevector-length objects))) (let lp ((i 0)) (when (< i len) (let ((x (bytevector-u8-ref objects i)) (y (bytevector-u8-ref objects (+ i 1))) (obj (match (bytevector-u8-ref objects (+ i 2)) (1 (spawn ^wall 'brick)) (id (error "invalid level object" id))))) ($ (grid-ref grid x y) obj)) (lp (+ i 3))))) ($ (grid-ref grid 3 7) (spawn ^exit)) ($ (grid-ref grid 4 3) (spawn ^clock-emitter 3)) ($ (grid-ref grid 5 3) (spawn ^wall 'copper)) ($ (grid-ref grid 6 5) (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) (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)))