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

Kill player when gate closes on them.

Browse source
This commit is contained in:
David Thompson 2024-05-22 09:29:44 -04:00
parent 68b427e387
commit 71d62e596e
3 changed files with 88 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

BIN
assets/sounds/die.wav Normal file
View file

Binary file not shown.

59
game.scm
View file

@ -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!)))

67
modules/game/actors.scm
View file

@ -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))