diff --git a/game.scm b/game.scm index f202a49..68283d7 100644 --- a/game.scm +++ b/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*)) diff --git a/modules/game/actors.scm b/modules/game/actors.scm index c7e0abb..02b554d 100644 --- a/modules/game/actors.scm +++ b/modules/game/actors.scm @@ -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))))))))) diff --git a/modules/game/level.scm b/modules/game/level.scm index 1e91c10..c7f2f2e 100644 --- a/modules/game/level.scm +++ b/modules/game/level.scm @@ -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))))) diff --git a/modules/game/levels/level-1.tmx b/modules/game/levels/level-1.tmx index 56386cc..ee9c9e3 100644 --- a/modules/game/levels/level-1.tmx +++ b/modules/game/levels/level-1.tmx @@ -1,5 +1,5 @@ - + @@ -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 @@ - + + + + + + + + + + + + diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm index c51b041..a4d5cf4 100644 --- a/scripts/compile-map.scm +++ b/scripts/compile-map.scm @@ -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))))