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
Show stats Download patch file Download diff file Expand all files Collapse all files

62
game.scm
View file

@ -102,20 +102,59 @@
(set! *snapshots* older-snapshots) (set! *snapshots* older-snapshots)
(media-play audio:undo)))) (media-play audio:undo))))
(define (sort lst <=)
(match lst
(() '())
((_) lst)
((pivot . rest)
(let lp ((left '()) (right '()) (pivot pivot) (rest rest))
(match rest
(() (append (sort left <=) (list pivot) (sort right <=)))
((x . rest)
(if (<= x pivot)
(lp (append left (list x)) right pivot rest)
(lp left (append right (list x)) pivot rest))))))))
(define (filter-map proc lst)
(let lp ((lst lst))
(match lst
(() '())
((head . tail)
(let ((head* (proc head)))
(if head*
(cons head* (lp tail))
(lp tail)))))))
(define (update-objects!) (define (update-objects!)
(set! *objects* (set! *objects*
;; TODO: Receive layer for sprite sorting ;; Filter out the objects that are baked into the background
;; and thus do not need to be rendered repeatedly. Then,
;; z-sort the list so we render in the correct order.
;; Finally, convert positions to vec2s for more efficient
;; rendering.
(map (match-lambda (map (match-lambda
((type #(x y) . properties) ((type #(x y _) . properties)
`(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties))) (pk 'obj `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties))))
($ (level-actor *level*) 'describe)))) (sort (filter-map (match-lambda
(((or 'wall 'exit) . _) #f)
(desc desc))
($ (level-actor *level*) 'describe))
(lambda (a b)
(match a
((_ #(_ _ az) . _)
(match b
((_ #(_ _ bz) . _)
(<= az bz))))))))))
(define (collected-gem? idx)
(not (memq idx *gems*)))
(define (load-level! idx) (define (load-level! idx)
(set! *state* 'play) (set! *state* 'play)
(set! *actormap* (make-whactormap)) (set! *actormap* (make-whactormap))
(clear-snapshots!) (clear-snapshots!)
(with-goblins (with-goblins
(set! *level* ((vector-ref levels idx) (not (memq idx *gems*)))) (set! *level* ((vector-ref levels idx) (collected-gem? idx)))
(update-objects!))) (update-objects!)))
(define (next-level!) (define (next-level!)
@ -172,6 +211,8 @@
'next-level) 'next-level)
(('gem) (('gem)
(media-play audio:pickup) (media-play audio:pickup)
;; TODO: Maybe show a little achievement popup when all gems
;; are collected?
(set! *gems* (cons *level-idx* *gems*)) (set! *gems* (cons *level-idx* *gems*))
#f) #f)
(_ #f))) (_ #f)))
@ -239,16 +280,21 @@
(define (draw-gem pos) (define (draw-gem pos)
(draw-tile context tileset 28 (vec2-x pos) (vec2-y pos))) (draw-tile context tileset 28 (vec2-x pos) (vec2-y pos)))
(define (draw-gate pos open?)
(draw-tile context tileset (if open? 46 45) (vec2-x pos) (vec2-y pos)))
(define (draw-object obj) (define (draw-object obj)
(match obj (match obj
(#f #f) (#f #f)
(('player pos) (draw-player pos)) (('player pos) (draw-player pos))
(('exit pos) (draw-exit pos)) ;; Wall and exit tiles are baked into the background layer.
(('wall pos type) (draw-wall type pos)) (('exit pos) #t)
(('wall pos type) #t)
(('block pos type) (draw-block type pos)) (('block pos type) (draw-block type pos))
(('clock-emitter pos) (draw-clock-emitter pos)) (('clock-emitter pos) (draw-clock-emitter pos))
(('floor-switch pos on?) (draw-floor-switch pos on?)) (('floor-switch pos on?) (draw-floor-switch pos on?))
(('gem pos) (draw-gem pos)))) (('gem pos) (draw-gem pos))
(('gate pos open?) (draw-gate pos open?))))
(define (draw-background) (define (draw-background)
(let* ((bv (level-background *level*)) (let* ((bv (level-background *level*))

91
modules/game/actors.scm
View file

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

14
modules/game/level.scm
View file

@ -37,12 +37,18 @@
(5 (spawn ^block x y 'copper)) (5 (spawn ^block x y 'copper))
(6 (spawn ^block x y 'crate)) (6 (spawn ^block x y 'crate))
(7 (spawn ^clock-emitter x y 4)) (7 (spawn ^clock-emitter x y 4))
(8 (spawn ^floor-switch x y)) (8 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
(target-y (bytevector-u8-ref objects (+ i 4))))
(spawn ^floor-switch x y target-x target-y)))
(9 (and spawn-gem? (spawn ^gem x y))) (9 (and spawn-gem? (spawn ^gem x y)))
(id (error "invalid level object" id))))) (10 (spawn ^gate x y))
(id (error "invalid level object" id))))
(i* (+ i (match id
(8 5) ; floor-switch
(_ 3)))))
(when obj (when obj
($ level* 'add-object obj)) ($ level* 'add-object obj))
(if (= id 3) ; player-spawn (if (= id 3) ; player-spawn
(lp (+ i 3) obj) (lp i* obj)
(lp (+ i 3) player))) (lp i* player)))
(%make-level background level* player))))) (%make-level background level* player)))))

21
modules/game/levels/level-1.tmx
View file

@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="20" height="15" tilewidth="16" tileheight="16" infinite="0" nextlayerid="3" nextobjectid="8"> <map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="20" height="15" tilewidth="16" tileheight="16" infinite="0" nextlayerid="3" nextobjectid="11">
<tileset firstgid="1" source="tiles.tsx"/> <tileset firstgid="1" source="tiles.tsx"/>
<layer id="1" name="background" width="20" height="15"> <layer id="1" name="background" width="20" height="15">
<data encoding="csv"> <data encoding="csv">
@ -9,9 +9,9 @@
23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23, 23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23,
23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23, 23,23,24,24,24,24,24,24,24,24,24,23,23,23,24,24,24,24,23,23,
23,23,24,24,24,24,24,24,24,24,24,24,28,24,24,24,24,24,23,23, 23,23,24,24,24,24,24,24,24,24,24,24,28,23,24,24,24,24,23,23,
23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23, 23,23,24,24,24,24,24,24,24,24,24,23,23,23,24,24,24,24,23,23,
23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23, 23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23,
23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
@ -22,7 +22,18 @@
</layer> </layer>
<objectgroup id="2" name="objects"> <objectgroup id="2" name="objects">
<object id="1" type="player-spawn" gid="1" x="96" y="112" width="16" height="16"/> <object id="1" type="player-spawn" gid="1" x="96" y="112" width="16" height="16"/>
<object id="6" type="floor-switch" gid="25" x="128" y="112" width="16" height="16"/> <object id="6" type="floor-switch" gid="25" x="128" y="112" width="16" height="16">
<properties>
<property name="target-x" type="int" value="11"/>
<property name="target-y" type="int" value="7"/>
</properties>
</object>
<object id="7" type="gem" gid="29" x="32" y="112" width="16" height="16"/> <object id="7" type="gem" gid="29" x="32" y="112" width="16" height="16"/>
<object id="8" type="gate" gid="46" x="176" y="112" width="16" height="16"/>
<object id="10" type="block" gid="30" x="112" y="112" width="16" height="16">
<properties>
<property name="kind" value="crate"/>
</properties>
</object>
</objectgroup> </objectgroup>
</map> </map>

6
scripts/compile-map.scm
View file

@ -554,6 +554,7 @@ the default ORIENTATION value of 'orthogonal' is supported."
(define obj:clock-emitter 7) (define obj:clock-emitter 7)
(define obj:floor-switch 8) (define obj:floor-switch 8)
(define obj:gem 9) (define obj:gem 9)
(define obj:gate 10)
(define (compile-environment-layer tile-map layer-name) (define (compile-environment-layer tile-map layer-name)
(let ((tw (tile-map-tile-width tile-map)) (let ((tw (tile-map-tile-width tile-map))
@ -595,8 +596,11 @@ the default ORIENTATION value of 'orthogonal' is supported."
("crate" (list x y obj:block:crate)) ("crate" (list x y obj:block:crate))
("copper" (list x y obj:block:copper)) ("copper" (list x y obj:block:copper))
(kind (error "unsupported block kind" kind)))) (kind (error "unsupported block kind" kind))))
('floor-switch (list x y obj:floor-switch)) ('floor-switch (list x y obj:floor-switch
(assq-ref properties 'target-x)
(assq-ref properties 'target-y)))
('gem (list x y obj:gem)) ('gem (list x y obj:gem))
('gate (list x y obj:gate))
(_ (error "unsupported object type" type))))) (_ (error "unsupported object type" type)))))
(object-layer-objects layer)))) (object-layer-objects layer))))