SuperKamiGuru/foss-mmo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add physical gates and finish floor switches.

Browse source
This commit is contained in:
David Thompson 2024-05-21 17:28:57 -04:00
parent ba7b9ea9d8
commit 4c12ccc559
5 changed files with 157 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

103
modules/game/actors.scm
View file

@ -7,6 +7,7 @@
^block
^clock-emitter
^floor-switch
^gate
^gem
^player
^level))
@ -22,7 +23,7 @@
;; TODO: Port actor-lib methods and use it.
(define (^exit bcom x y)
(define position (vector x y))
(define position (vector x y 1))
(match-lambda*
(('type) 'exit)
(('position) position)
@ -37,7 +38,7 @@
;; TODO: Maybe make separate actors for conductive vs. inert walls.
(define (^wall bcom x y type)
(define position (vector x y))
(define position (vector x y 1))
(match-lambda*
(('type) 'wall)
(('position) position)
@ -57,7 +58,7 @@
;; TODO: Maybe make separate actors for conductive vs. inert blocks.
(define (^block bcom x y type)
(define position (spawn ^cell (vector x y)))
(define position (spawn ^cell (vector x y 1)))
(define pushed? (spawn ^cell))
(match-lambda*
(('type) 'block)
@ -72,25 +73,31 @@
(_ #f)))
(('set-wire-state type)
(match ($ position)
(#(x y)
(#(x y _)
(bcom (^block bcom x y type)))))
(('alive?) #t)
(('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)))))))))
(when (eq? ($ other 'type) 'player)
(match ($ position)
(#(x y z)
(match offset
(#(dx dy)
(let ((x (+ x dx))
(y (+ y dy)))
(let ((occupant-types
(map (lambda (obj) ($ obj 'type))
($ grid-info 'occupants x y))))
(match occupant-types
((or () ('switch))
($ pushed? #t)
($ position (vector x y z)))
(_ #f))))))))))
(('pushed?) ($ pushed?))))
(define (^clock-emitter bcom x y interval)
(define timer (spawn ^cell 0))
(define position (vector x y))
(define timer (spawn ^cell 1))
(define position (vector x y 0))
(match-lambda*
(('type) 'emitter)
(('position) position)
@ -111,8 +118,8 @@
(('describe) `(clock-emitter ,position))
(('collide other offset grid-info) #f)))
(define (^floor-switch bcom x y)
(define position (vector x y))
(define (^floor-switch bcom x y target-x target-y)
(define position (vector x y 0))
(define on? (spawn ^cell))
(match-lambda*
(('type) 'switch)
@ -123,16 +130,24 @@
(('exit obj grid-info)
(when (= (length ($ grid-info 'occupants x y)) 1)
(pk 'OFF)
($ on? #f)))
($ on? #f)
(match ($ grid-info 'occupants target-x target-y)
(() (pk "no switch target!"))
((target . _)
($ target 'deactivate)))))
(('wire-state) #f)
(('alive?) #t)
(('describe) `(floor-switch ,position ,($ on?)))
(('collide other offset grid-info)
(pk 'ON)
($ on? #t))))
($ on? #t)
(match ($ grid-info 'occupants target-x target-y)
(() (pk "no switch target!"))
((target . _)
($ target 'activate))))))
(define (^gem bcom x y)
(define position (vector x y))
(define position (vector x y 1))
(define picked-up? (spawn ^cell))
(match-lambda*
(('type) 'gem)
@ -147,8 +162,25 @@
(when (eq? ($ other 'type) 'player)
($ picked-up? #t)))))
(define (^gate bcom x y)
(define position (vector x y 1))
(define open? (spawn ^cell))
(match-lambda*
(('type) 'gate)
(('position) position)
(('tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('activate) ($ open? #t))
(('deactivate) ($ open? #f))
(('wire-state) #f)
(('alive?) #t)
(('open?) ($ open?))
(('describe) `(gate ,position ,($ open?)))
(('collide other offset grid-info) #f)))
(define (^player bcom x y)
(define position (spawn ^cell (vector x y)))
(define position (spawn ^cell (vector x y 2)))
(define velocity (spawn ^cell #(0 0)))
(define event (spawn ^cell))
(match-lambda*
@ -165,10 +197,10 @@
(('tick grid-info)
($ event #f)
(match ($ position)
(#(x y)
(#(x y z)
(match ($ velocity)
(#(dx dy)
($ position (vector (+ x dx) (+ y dy)))
($ position (vector (+ x dx) (+ y dy) z))
($ velocity #(0 0)))))))
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
@ -178,10 +210,10 @@
(('collide other offset grid-info)
(define (reverse-move)
(match ($ position)
(#(x y)
(#(x y z)
(match offset
(#(dx dy)
($ position (vector (- x dx) (- y dy))))))))
($ position (vector (- x dx) (- y dy) z)))))))
(match ($ other 'type)
('exit ($ event '(exit)))
('block
@ -192,6 +224,10 @@
($ event '(bump)))))
('switch ($ event '(switch)))
('gem ($ event '(gem)))
('gate
(unless ($ other 'open?)
(reverse-move)
($ event '(bump))))
(_
(reverse-move)
($ event '(bump)))))
@ -243,7 +279,7 @@
(define (maybe-update-grid obj prev-pos resolved-pos)
(unless (equal? prev-pos resolved-pos)
(match prev-pos
(#(x y)
(#(x y _)
(let* ((cell (grid-ref grid x y))
(remaining (delq obj ($ cell))))
($ cell remaining)
@ -251,7 +287,7 @@
($ other 'exit obj grid-info))
remaining))))
(match resolved-pos
(#(x y)
(#(x y _)
(let* ((cell (grid-ref grid x y))
(occupants ($ cell)))
($ cell (cons obj occupants))
@ -260,7 +296,7 @@
occupants))))))
(define (collide obj pos prev-pos)
(match pos
(#(x y)
(#(x y _)
(let lp ((objects ($ (grid-ref grid x y))))
(match objects
(() (maybe-update-grid obj prev-pos ($ obj 'position)))
@ -269,12 +305,17 @@
(lp rest)
(let ((other-prev-pos ($ other 'position)))
(match prev-pos
(#(prev-x prev-y)
(#(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))
;; If collision resolution displaced the other
;; object, then recur and check collision for
;; it.
(let ((other-pos ($ other 'position)))
(unless (equal? other-pos other-prev-pos)
(collide other other-pos other-prev-pos)))
(lp rest))))))))))))
(define (tick)
(define (neighbors x y)
@ -343,6 +384,6 @@
(('add-object obj)
($ objects (cons obj ($ objects)))
(match ($ obj 'position)
(#(x y)
(#(x y _)
(let ((cell (grid-ref grid x y)))
($ cell (cons obj ($ cell)))))))))