diff --git a/assets/sounds/die.wav b/assets/sounds/die.wav new file mode 100644 index 0000000..fdaefa6 Binary files /dev/null and b/assets/sounds/die.wav differ diff --git a/game.scm b/game.scm index d3de151..9268b20 100644 --- a/game.scm +++ b/game.scm @@ -68,6 +68,7 @@ (define audio:no (load-sound-effect "no")) (define audio:exit (load-sound-effect "exit")) (define audio:pickup (load-sound-effect "pickup")) +(define audio:die (load-sound-effect "die")) ;; Game state (define *state* #f) @@ -198,29 +199,41 @@ (define (move-player dir) (define (do-move) (with-goblins - ($ (level-player *level*) 'move dir) - ($ (level-actor *level*) 'tick) - (define result - (match ($ (level-player *level*) 'event) - (('bump) - (media-play audio:bump) - #f) - (('push) - (media-play audio:push) - #f) - (('exit) - (media-play audio:exit) - '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))) - (update-objects!) - result)) - (save-snapshot!) + (let ((player (level-player *level*))) + (if ($ player 'alive?) + (begin + ($ player 'move dir) + ($ (level-actor *level*) 'tick) + ;; TODO: Need a better way to receive events to play sounds + ;; and emit particles and stuff so any actor can trigger + ;; events. + (let ((result + (match ($ player 'event) + (('bump) + (media-play audio:bump) + #f) + (('push) + (media-play audio:push) + #f) + (('exit) + (media-play audio:exit) + 'next-level) + (('die) + (media-play audio:die) + #f) + (('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)))) + (update-objects!) + (save-snapshot!) + result)) + (begin + (media-play audio:no) + #f))))) (when (eq? (do-move) 'next-level) (next-level!))) diff --git a/modules/game/actors.scm b/modules/game/actors.scm index 2c0af90..4fecf32 100644 --- a/modules/game/actors.scm +++ b/modules/game/actors.scm @@ -39,6 +39,7 @@ (('type) 'exit) (('position) position) (('tick grid-info) #f) + (('post-tick grid-info) #f) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) #f) @@ -54,6 +55,7 @@ (('type) 'wall) (('position) position) (('tick grid-info) #f) + (('post-tick grid-info) #f) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) @@ -80,6 +82,7 @@ (('type) 'block) (('position) ($ position)) (('tick grid-info) ($ pushed? #f)) + (('post-tick grid-info) #f) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) @@ -123,6 +126,7 @@ (('type) 'emitter) (('position) position) (('tick grid-info) ($ timer (+ ($ timer) 1))) + (('post-tick grid-info) #f) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) @@ -155,6 +159,7 @@ (('type) 'switch) (('position) position) (('tick grid-info) #f) + (('post-tick grid-info) #f) (('enter obj grid-info) ($ on? #t)) (('exit obj grid-info) @@ -181,6 +186,7 @@ (('type) 'switch) (('position) position) (('tick grid-info) #f) + (('post-tick grid-info) #f) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) #f) @@ -210,6 +216,7 @@ (('type) 'gem) (('position) position) (('tick grid-info) #f) + (('post-tick grid-info) #f) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) #f) @@ -227,6 +234,7 @@ (('type) 'gate) (('position) position) (('tick grid-info) #f) + (('post-tick grid-info) #f) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('activate) ($ open? #t)) @@ -245,6 +253,7 @@ (('type) 'emitter) (('position) position) (('tick grid-info) #f) + (('post-tick grid-info) #f) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) ($ state)) @@ -268,6 +277,7 @@ (define (^player bcom x y) (define position (spawn ^cell (vector x y 2))) (define velocity (spawn ^cell #(0 0))) + (define alive? (spawn ^cell #t)) (define event (spawn ^cell)) (match-lambda* (('type) 'player) @@ -281,18 +291,39 @@ ('down #(0 1)) (_ (error "invalid direction" dir))))) (('tick grid-info) - ($ event #f) + ;; Search for objects that were fine to step onto last turn, but + ;; have become deadly this turn. If (match ($ position) (#(x y z) + ($ event #f) (match ($ velocity) (#(dx dy) ($ position (vector (+ x dx) (+ y dy) z)) ($ velocity #(0 0))))))) + (('post-tick grid-info) + (match ($ position) + (#(x y z) + (let lp ((objs ($ grid-info 'occupants x y))) + (match objs + ;; All is well. Move by current velocity. + (() + (match ($ velocity) + (#(dx dy) + ($ position (vector (+ x dx) (+ y dy) z)) + ($ velocity #(0 0))))) + ((obj . rest) + (match ($ obj 'type) + ('gate + ;; Ouch, a gate closed on the player! + (unless ($ obj 'open?) + ($ alive? #f) + ($ event '(die)))) + (_ (lp rest))))))))) (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) #f) (('update-wire-state grid-info) #f) - (('alive?) #t) + (('alive?) ($ alive?)) (('describe) `(player ,($ position))) (('collide other offset grid-info) (define (reverse-move) @@ -451,28 +482,34 @@ (unless (equal? other-pos other-prev-pos) (collide other other-pos other-prev-pos))) (lp rest)))))))))))) - (define (tick) - ;; Tick each object and check for collisions. + (define (iter-objects proc) ($ objects (let lp ((objs ($ objects))) (match objs (() '()) ((obj . rest) - (let ((prev-pos ($ obj 'position))) - ($ obj 'tick grid-info) - ;; Only check collisions for movable objects. - (let ((desired-pos ($ obj 'position))) - (unless (equal? prev-pos desired-pos) - (collide obj desired-pos prev-pos))) - ;; Cull dead objects. - (if ($ obj 'alive?) - (cons obj (lp rest)) - (lp rest))))))) + (proc obj) + ;; Cull dead objects. + (if ($ obj 'alive?) + (cons obj (lp rest)) + (lp rest))))))) + (define (tick) + ;; Tick each object and check for collisions. + (iter-objects + (lambda (obj) + (let ((prev-pos ($ obj 'position))) + ($ obj 'tick grid-info) + ;; Only check collisions for movable objects. + (let ((desired-pos ($ obj 'position))) + (unless (equal? prev-pos desired-pos) + (collide obj desired-pos prev-pos)))))) ;; Advance Wirewold simulation. (refresh-wire-grid) (for-each (lambda (obj) ($ obj 'update-wire-state grid-info)) - ($ objects))) + ($ objects)) + ;; Run post-tick hooks. + (iter-objects (lambda (obj) ($ obj 'post-tick grid-info)))) (match-lambda* (('tick) (tick))