Add physical gates and finish floor switches.
This commit is contained in:
parent
ba7b9ea9d8
commit
4c12ccc559
5 changed files with 157 additions and 49 deletions
62
game.scm
62
game.scm
|
@ -102,20 +102,59 @@
|
|||
(set! *snapshots* older-snapshots)
|
||||
(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!)
|
||||
(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
|
||||
((type #(x y) . properties)
|
||||
`(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties)))
|
||||
($ (level-actor *level*) 'describe))))
|
||||
((type #(x y _) . properties)
|
||||
(pk 'obj `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties))))
|
||||
(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)
|
||||
(set! *state* 'play)
|
||||
(set! *actormap* (make-whactormap))
|
||||
(clear-snapshots!)
|
||||
(with-goblins
|
||||
(set! *level* ((vector-ref levels idx) (not (memq idx *gems*))))
|
||||
(set! *level* ((vector-ref levels idx) (collected-gem? idx)))
|
||||
(update-objects!)))
|
||||
|
||||
(define (next-level!)
|
||||
|
@ -172,6 +211,8 @@
|
|||
'next-level)
|
||||
(('gem)
|
||||
(media-play audio:pickup)
|
||||
;; TODO: Maybe show a little achievement popup when all gems
|
||||
;; are collected?
|
||||
(set! *gems* (cons *level-idx* *gems*))
|
||||
#f)
|
||||
(_ #f)))
|
||||
|
@ -239,16 +280,21 @@
|
|||
(define (draw-gem 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)
|
||||
(match obj
|
||||
(#f #f)
|
||||
(('player pos) (draw-player pos))
|
||||
(('exit pos) (draw-exit pos))
|
||||
(('wall pos type) (draw-wall type pos))
|
||||
;; Wall and exit tiles are baked into the background layer.
|
||||
(('exit pos) #t)
|
||||
(('wall pos type) #t)
|
||||
(('block pos type) (draw-block type pos))
|
||||
(('clock-emitter pos) (draw-clock-emitter pos))
|
||||
(('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)
|
||||
(let* ((bv (level-background *level*))
|
||||
|
|
|
@ -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)
|
||||
(when (eq? ($ other 'type) 'player)
|
||||
(match ($ position)
|
||||
(#(x y)
|
||||
(#(x y z)
|
||||
(match offset
|
||||
(#(dx dy)
|
||||
(let ((x (+ x dx))
|
||||
(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)
|
||||
($ position (vector x y)))))))))
|
||||
($ 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)))))))))
|
||||
|
|
|
@ -37,12 +37,18 @@
|
|||
(5 (spawn ^block x y 'copper))
|
||||
(6 (spawn ^block x y 'crate))
|
||||
(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)))
|
||||
(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
|
||||
($ level* 'add-object obj))
|
||||
(if (= id 3) ; player-spawn
|
||||
(lp (+ i 3) obj)
|
||||
(lp (+ i 3) player)))
|
||||
(lp i* obj)
|
||||
(lp i* player)))
|
||||
(%make-level background level* player)))))
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
<?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"/>
|
||||
<layer id="1" name="background" width="20" height="15">
|
||||
<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,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,24,28,24,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,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,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,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>
|
||||
<objectgroup id="2" name="objects">
|
||||
<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="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>
|
||||
</map>
|
||||
|
|
|
@ -554,6 +554,7 @@ the default ORIENTATION value of 'orthogonal' is supported."
|
|||
(define obj:clock-emitter 7)
|
||||
(define obj:floor-switch 8)
|
||||
(define obj:gem 9)
|
||||
(define obj:gate 10)
|
||||
|
||||
(define (compile-environment-layer tile-map layer-name)
|
||||
(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))
|
||||
("copper" (list x y obj:block:copper))
|
||||
(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))
|
||||
('gate (list x y obj:gate))
|
||||
(_ (error "unsupported object type" type)))))
|
||||
(object-layer-objects layer))))
|
||||
|
||||
|
|
Loading…
Add table
Reference in a new issue