(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))))) ;; TODO: Add layer info to 'describe' output for sorting sprites when ;; rendering. ;; TODO: Port actor-lib methods and use it. (define (^exit bcom x y) (define position (vector x y)) (match-lambda* (('type) 'exit) (('position) position) (('tick) #f) (('wire-state) #f) (('set-wire-state) #f) (('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)) (match-lambda* (('type) 'wall) (('position) position) (('tick) #f) (('wire-state) (match type ((or 'copper 'electron-head 'electron-tail) type) (_ #f))) (('set-wire-state type) (bcom (^wall bcom x y type))) (('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))) (define pushed? (spawn ^cell)) (match-lambda* (('type) 'block) (('position) ($ position)) (('tick) ($ pushed? #f)) (('wire-state) (match type ((or 'copper 'electron-head 'electron-tail) type) (_ #f))) (('set-wire-state type) (match ($ position) (#(x y) (bcom (^block bcom x y type))))) (('describe) `(block ,($ position) ,type)) (('collide other offset grid-info) ;; TODO: Only push if there's not a wall in the destination. (match ($ position) (#(x y) (match offset (#(dx dy) (let ((x (+ x dx)) (y (+ y dy))) (unless ($ grid-info 'occupied? x y) ($ pushed? #t) ($ position (vector x y))))))))) (('pushed?) ($ pushed?)))) (define (^clock-emitter bcom x y interval) (define timer (spawn ^cell 0)) (define position (vector x y)) (match-lambda* (('type) 'emitter) (('position) position) (('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 ,position)) (('collide other offset grid-info) #f))) (define (^player bcom x y) (define position (spawn ^cell (vector x y))) (define velocity (spawn ^cell #(0 0))) (define event (spawn ^cell)) (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) ($ event #f) (match ($ position) (#(x y) (match ($ velocity) (#(dx dy) ($ position (vector (+ x dx) (+ y dy))) ($ velocity #(0 0))))))) (('wire-state) #f) (('describe) `(player ,($ position))) (('collide other offset grid-info) (define (reverse-move) (match ($ position) (#(x y) (match offset (#(dx dy) ($ position (vector (- x dx) (- y dy)))))))) (match ($ other 'type) ('exit ($ event '(exit))) ('block (if ($ other 'pushed?) ($ event '(push)) (begin (reverse-move) ($ event '(bump))))) (_ (reverse-move) ($ event '(bump))))) (('event) ($ event)))) (define (^level bcom width height) (define objects (spawn ^cell '())) ;; 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 '())) ;; Read-only access to query the grid. (define (^grid-info bcom) (match-lambda* (('occupied? x y) (not (null? ($ (grid-ref grid x y))))))) (define grid-info (spawn ^grid-info)) (define (wrap-x x) (modulo x width)) (define (wrap-y y) (modulo y height)) (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))) ($ cell (delq obj ($ cell)))))) (match resolved-pos (#(x y) (let ((cell (grid-ref grid x y))) ($ cell (cons obj ($ cell)))))))) (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) (maybe-update-grid other other-prev-pos ($ other 'position)) (lp rest)))))))))))) (define (tick) (define (neighbors x y) (define (check x y) (match ($ (grid-ref/wrap grid x y)) (() 0) ;; TODO: Handle tiles with many occupants. ((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))) ;; Tick each object and check for collisions. (for-each (lambda (obj) (let ((prev-pos ($ obj 'position))) ($ obj 'tick) ;; Only check collisions for movable objects. (let ((desired-pos ($ obj 'position))) (unless (equal? prev-pos desired-pos) (collide obj desired-pos prev-pos))))) ($ objects)) ;; Advance Wirewold simulation. (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)) (() (x-loop (1+ x) updates)) ;; TODO: Handle many occupants ((refr . _) (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)))) (match-lambda* (('tick) (tick)) (('describe) (map (lambda (obj) ($ obj 'describe)) ($ objects))) (('add-object obj) ($ objects (cons obj ($ objects))) (match ($ obj 'position) (#(x y) (let ((cell (grid-ref grid x y))) ($ cell (cons obj ($ cell)))))))))