2024-05-18 14:04:35 -04:00
|
|
|
(define-module (game actors)
|
|
|
|
#:use-module (goblins core)
|
|
|
|
#:use-module (ice-9 match)
|
|
|
|
#:export (^cell
|
2024-05-20 12:15:39 -04:00
|
|
|
^exit
|
|
|
|
^wall
|
|
|
|
^block
|
|
|
|
^clock-emitter
|
|
|
|
^player
|
2024-05-18 14:04:35 -04:00
|
|
|
^level))
|
|
|
|
|
|
|
|
(define* (^cell bcom #:optional val)
|
|
|
|
(case-lambda
|
|
|
|
(() val)
|
|
|
|
((new-val)
|
|
|
|
(bcom (^cell bcom new-val)))))
|
|
|
|
|
2024-05-20 22:12:35 -04:00
|
|
|
;; 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))
|
2024-05-19 06:15:27 -04:00
|
|
|
(match-lambda*
|
2024-05-20 22:12:35 -04:00
|
|
|
(('type) 'exit)
|
|
|
|
(('position) position)
|
2024-05-19 06:15:27 -04:00
|
|
|
(('tick) #f)
|
|
|
|
(('wire-state) #f)
|
|
|
|
(('set-wire-state) #f)
|
2024-05-20 22:12:35 -04:00
|
|
|
(('describe) `(exit ,position))
|
|
|
|
(('collide other offset grid-info) #f)))
|
2024-05-19 06:15:27 -04:00
|
|
|
|
2024-05-20 22:12:35 -04:00
|
|
|
;; TODO: Maybe make separate actors for conductive vs. inert walls.
|
|
|
|
(define (^wall bcom x y type)
|
|
|
|
(define position (vector x y))
|
2024-05-18 14:04:35 -04:00
|
|
|
(match-lambda*
|
2024-05-20 22:12:35 -04:00
|
|
|
(('type) 'wall)
|
|
|
|
(('position) position)
|
2024-05-18 14:04:35 -04:00
|
|
|
(('tick) #f)
|
|
|
|
(('wire-state)
|
|
|
|
(match type
|
|
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
|
|
type)
|
|
|
|
(_ #f)))
|
|
|
|
(('set-wire-state type)
|
2024-05-20 22:12:35 -04:00
|
|
|
(bcom (^wall bcom x y type)))
|
|
|
|
(('describe) `(wall ,position ,type))
|
|
|
|
(('collide other offset grid-info) #f)))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
2024-05-20 22:12:35 -04:00
|
|
|
;; 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))
|
2024-05-18 14:04:35 -04:00
|
|
|
(match-lambda*
|
2024-05-20 22:12:35 -04:00
|
|
|
(('type) 'block)
|
|
|
|
(('position) ($ position))
|
|
|
|
(('tick) ($ pushed? #f))
|
2024-05-18 14:04:35 -04:00
|
|
|
(('wire-state)
|
|
|
|
(match type
|
|
|
|
((or 'copper 'electron-head 'electron-tail)
|
|
|
|
type)
|
|
|
|
(_ #f)))
|
|
|
|
(('set-wire-state type)
|
2024-05-20 22:12:35 -04:00
|
|
|
(match ($ position)
|
|
|
|
(#(x y)
|
|
|
|
(bcom (^block bcom x y type)))))
|
|
|
|
(('describe) `(block ,($ position) ,type))
|
|
|
|
(('collide other offset grid-info)
|
|
|
|
(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?))))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
2024-05-20 22:12:35 -04:00
|
|
|
(define (^clock-emitter bcom x y interval)
|
2024-05-18 14:04:35 -04:00
|
|
|
(define timer (spawn ^cell 0))
|
2024-05-20 22:12:35 -04:00
|
|
|
(define position (vector x y))
|
2024-05-18 14:04:35 -04:00
|
|
|
(match-lambda*
|
2024-05-20 22:12:35 -04:00
|
|
|
(('type) 'emitter)
|
|
|
|
(('position) position)
|
2024-05-18 14:04:35 -04:00
|
|
|
(('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)
|
2024-05-20 22:12:35 -04:00
|
|
|
(('describe) `(clock-emitter ,position))
|
|
|
|
(('collide other offset grid-info) #f)))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
2024-05-20 22:12:35 -04:00
|
|
|
(define (^player bcom x y)
|
|
|
|
(define position (spawn ^cell (vector x y)))
|
|
|
|
(define velocity (spawn ^cell #(0 0)))
|
|
|
|
(define event (spawn ^cell))
|
2024-05-18 14:04:35 -04:00
|
|
|
(match-lambda*
|
2024-05-20 22:12:35 -04:00
|
|
|
(('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)))))))
|
2024-05-18 14:04:35 -04:00
|
|
|
(('wire-state) #f)
|
2024-05-20 22:12:35 -04:00
|
|
|
(('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))))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
2024-05-20 12:15:39 -04:00
|
|
|
(define (^level bcom width height)
|
2024-05-20 22:12:35 -04:00
|
|
|
(define objects (spawn ^cell '()))
|
|
|
|
|
|
|
|
;; Spatial partition
|
2024-05-18 14:04:35 -04:00
|
|
|
(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)))))
|
2024-05-20 22:12:35 -04:00
|
|
|
(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 (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))))))))))))
|
2024-05-18 14:04:35 -04:00
|
|
|
(define (tick)
|
|
|
|
(define (neighbors x y)
|
|
|
|
(define (check x y)
|
|
|
|
(match ($ (grid-ref/wrap grid x y))
|
2024-05-20 22:12:35 -04:00
|
|
|
(() 0)
|
|
|
|
;; TODO: Handle tiles with many occupants.
|
|
|
|
((refr . _)
|
2024-05-18 14:04:35 -04:00
|
|
|
(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)))
|
2024-05-20 22:12:35 -04:00
|
|
|
;; 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.
|
2024-05-18 14:04:35 -04:00
|
|
|
(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))
|
2024-05-20 22:12:35 -04:00
|
|
|
(() (x-loop (1+ x) updates))
|
|
|
|
;; TODO: Handle many occupants
|
|
|
|
((refr . _)
|
2024-05-18 14:04:35 -04:00
|
|
|
(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*
|
2024-05-20 22:12:35 -04:00
|
|
|
(('tick) (tick))
|
2024-05-18 14:04:35 -04:00
|
|
|
(('describe)
|
2024-05-20 22:12:35 -04:00
|
|
|
(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)))))))))
|