Big actor refactor; use local storage for auto-save.
This commit is contained in:
David Thompson
parent
ce0c002e8b
commit
816d9d149d
7 changed files with 321 additions and 202 deletions
|
|
@ -15,16 +15,27 @@
|
|||
((new-val)
|
||||
(bcom (^cell bcom new-val)))))
|
||||
|
||||
(define (^exit bcom)
|
||||
;; 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))
|
||||
(('collide) 'exit)))
|
||||
(('describe) `(exit ,position))
|
||||
(('collide other offset grid-info) #f)))
|
||||
|
||||
(define (^wall bcom type)
|
||||
;; 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
|
||||
|
|
@ -32,26 +43,47 @@
|
|||
type)
|
||||
(_ #f)))
|
||||
(('set-wire-state type)
|
||||
(bcom (^wall bcom type)))
|
||||
(('describe) `(wall ,type))
|
||||
(('collide) 'bump)))
|
||||
(bcom (^wall bcom x y type)))
|
||||
(('describe) `(wall ,position ,type))
|
||||
(('collide other offset grid-info) #f)))
|
||||
|
||||
(define (^block bcom type)
|
||||
;; 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*
|
||||
(('tick) #f)
|
||||
(('type) 'block)
|
||||
(('position) ($ position))
|
||||
(('tick) ($ pushed? #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)))
|
||||
(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 interval)
|
||||
(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)))
|
||||
|
|
@ -63,28 +95,58 @@
|
|||
(else
|
||||
'copper))))
|
||||
(('set-wire-state type) #f)
|
||||
(('describe) '(clock-emitter))
|
||||
(('collide) 'bump)))
|
||||
(('describe) `(clock-emitter ,position))
|
||||
(('collide other offset grid-info) #f)))
|
||||
|
||||
(define (^player bcom)
|
||||
(define (^player bcom x y)
|
||||
(define position (spawn ^cell (vector x y)))
|
||||
(define velocity (spawn ^cell #(0 0)))
|
||||
(define event (spawn ^cell))
|
||||
(match-lambda*
|
||||
(('tick) #f)
|
||||
(('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))))
|
||||
(('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 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 objects (spawn ^cell '()))
|
||||
|
||||
;; Spatial partition
|
||||
(define (for-each-coord proc)
|
||||
(let y-loop ((y 0))
|
||||
(when (< y height)
|
||||
|
|
@ -93,55 +155,74 @@
|
|||
(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))
|
||||
;; 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 (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))
|
||||
(#f 0)
|
||||
(refr
|
||||
(() 0)
|
||||
;; TODO: Handle tiles with many occupants.
|
||||
((refr . _)
|
||||
(match ($ refr 'wire-state)
|
||||
('electron-head 1)
|
||||
(_ 0)))))
|
||||
|
|
@ -153,6 +234,16 @@
|
|||
(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)))
|
||||
|
|
@ -162,9 +253,9 @@
|
|||
(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)
|
||||
(() (x-loop (1+ x) updates))
|
||||
;; TODO: Handle many occupants
|
||||
((refr . _)
|
||||
(match ($ refr 'wire-state)
|
||||
(#f (x-loop (1+ x) updates))
|
||||
('copper
|
||||
|
|
@ -178,32 +269,13 @@
|
|||
updates)))
|
||||
updates))))
|
||||
|
||||
;; Initialize grid cells
|
||||
(for-each-coord
|
||||
(lambda (x y)
|
||||
(grid-set! grid x y (spawn ^cell))))
|
||||
|
||||
(match-lambda*
|
||||
(('tick) (tick))
|
||||
(('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)))
|
||||
(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)))))))))
|
||||
|
|
|
|||
|
|
@ -7,37 +7,39 @@
|
|||
#:export (make-level
|
||||
level?
|
||||
level-background
|
||||
level-actor))
|
||||
level-actor
|
||||
level-player))
|
||||
|
||||
;; Client-side rendering info coupled with level actor that contains
|
||||
;; game state.
|
||||
(define-record-type <level>
|
||||
(%make-level background actor)
|
||||
(%make-level background actor player)
|
||||
level?
|
||||
(background level-background)
|
||||
(actor level-actor))
|
||||
(actor level-actor)
|
||||
(player level-player))
|
||||
|
||||
(define (make-level width height background objects)
|
||||
(let ((level* (spawn ^level width height)))
|
||||
;; 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))
|
||||
(let ((level* (spawn ^level width height))
|
||||
(len (bytevector-length objects)))
|
||||
;; Parsed packed object data and spawn objects, making special
|
||||
;; note of the player.
|
||||
(let lp ((i 0) (player #f))
|
||||
(if (< i len)
|
||||
(let* ((x (bytevector-u8-ref objects i))
|
||||
(y (bytevector-u8-ref objects (+ i 1)))
|
||||
(id (bytevector-u8-ref objects (+ i 2))))
|
||||
(id (bytevector-u8-ref objects (+ i 2)))
|
||||
(obj (match id
|
||||
(1 (spawn ^wall x y 'brick))
|
||||
(2 (spawn ^wall x y 'copper))
|
||||
(3 (spawn ^player x y))
|
||||
(4 (spawn ^exit x y))
|
||||
(5 (spawn ^block x y 'copper))
|
||||
(6 (spawn ^block x y 'crate))
|
||||
(7 (spawn ^clock-emitter x y 4))
|
||||
(id (error "invalid level object" id)))))
|
||||
($ level* 'add-object obj)
|
||||
(if (= id 3) ; player-spawn
|
||||
(begin
|
||||
(pk 'spawn-player x y)
|
||||
($ level* 'warp-player x y))
|
||||
(let ((obj (match id
|
||||
(1 (spawn ^wall 'brick))
|
||||
(2 (spawn ^wall 'copper))
|
||||
(4 (spawn ^exit))
|
||||
(5 (spawn ^block 'copper))
|
||||
(6 (spawn ^block 'crate))
|
||||
(7 (spawn ^clock-emitter 4))
|
||||
(id (error "invalid level object" id)))))
|
||||
($ level* 'set-object x y obj))))
|
||||
(lp (+ i 3)))))
|
||||
(%make-level background level*)))
|
||||
(lp (+ i 3) obj)
|
||||
(lp (+ i 3) player)))
|
||||
(%make-level background level* player)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue