Allow any actor to push an event to the UI.

This commit is contained in:
David Thompson 2024-05-22 21:53:17 -04:00
parent bcb235bd82
commit a24d737bc7
4 changed files with 99 additions and 74 deletions

Binary file not shown.

Binary file not shown.

View file

@ -67,6 +67,8 @@
(define audio:exit (load-sound-effect "exit"))
(define audio:pickup (load-sound-effect "pickup"))
(define audio:die (load-sound-effect "die"))
(define audio:electric-switch-on (load-sound-effect "electric-switch-on"))
(define audio:electric-switch-off (load-sound-effect "electric-switch-off"))
;; Game state
(define *state* #f)
@ -196,45 +198,45 @@
;; Update loop
(define (move-player dir)
(define (do-move)
(with-goblins
(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)
(play-sound-effect audio:bump)
#f)
(('push)
(play-sound-effect audio:push)
#f)
(('exit)
(play-sound-effect audio:exit)
'next-level)
(('die)
(play-sound-effect audio:die)
#f)
(('gem)
(play-sound-effect 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
(play-sound-effect audio:no)
#f)))))
(when (eq? (do-move) 'next-level)
(next-level!)))
(define level-complete? #f)
(with-goblins
(let ((player (level-player *level*))
(level (level-actor *level*)))
(cond
(($ player 'alive?)
(begin
($ player 'move dir)
($ level 'tick)
(let lp ((events ($ level 'flush-events)))
(match events
(() (values))
((event . rest)
(match (pk 'event event)
(('bump x y)
(play-sound-effect audio:bump))
(('push x y)
(play-sound-effect audio:push))
(('exit x y)
(play-sound-effect audio:exit)
(set! level-complete? #t))
(('player-death x y)
(play-sound-effect audio:die))
(('pickup x y)
(play-sound-effect audio:pickup)
;; TODO: Maybe show a little achievement popup when all gems
;; are collected?
(set! *gems* (cons *level-idx* *gems*)))
(('electric-switch-on x y)
(play-sound-effect audio:electric-switch-on))
(('electric-switch-off x y)
(play-sound-effect audio:electric-switch-off))
(_ (values)))
(lp rest))))
(update-objects!)
(save-snapshot!)))
(else
(play-sound-effect audio:no)))))
(when level-complete? (next-level!)))
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update)

View file

@ -168,7 +168,9 @@
($ on? #f)
(match (first-non-player-occupant grid-info target-x target-y)
(#f (pk "no switch target!"))
(target ($ target 'deactivate)))))
(target
($ grid-info 'append-event `(floor-switch-off ,x ,y))
($ target 'deactivate)))))
(('wire-state grid-info) #f)
(('update-wire-state grid-info) #f)
(('alive?) #t)
@ -177,7 +179,9 @@
($ on? #t)
(match (first-non-player-occupant grid-info target-x target-y)
(#f (pk "no switch target!"))
(target ($ target 'activate))))))
(target
($ grid-info 'append-event `(floor-switch-on ,x ,y))
($ target 'activate))))))
(define (^electric-switch bcom x y target-x target-y)
(define position (vector x y 0))
@ -199,13 +203,17 @@
($ on? #f)
(match (first-non-player-occupant grid-info target-x target-y)
(#f (pk "no switch target!"))
(target ($ target 'deactivate)))))
(target
($ grid-info 'append-event `(electric-switch-off ,x ,y))
($ target 'deactivate)))))
(when (>= ($ grid-info 'wireworld-neighbor-count x y) 1)
($ on? #t)
($ timer 2)
(match (first-non-player-occupant grid-info target-x target-y)
(#f (pk "no switch target!"))
(target ($ target 'activate))))))
(target
($ grid-info 'append-event `(electric-switch-on ,x ,y))
($ target 'activate))))))
(('alive?) #t)
(('describe) `(electric-switch ,position ,($ on?)))
(('collide other offset grid-info) #f)))
@ -238,13 +246,15 @@
(if ($ electron?)
(begin
($ state 'electron-head)
($ electron? #f))
($ electron? #f)
($ grid-info 'append-event `(receive-electron ,x ,y)))
(let ((neighbors ($ grid-info 'wireworld-neighbor-count x y)))
(if (<= 1 neighbors 2)
(begin
($ state 'electron-head)
;; Forward an electron head to the receiver.
($ (find-receiver grid-info) 'give-electron))
($ (find-receiver grid-info) 'give-electron)
($ grid-info 'append-event `(send-electron ,x ,y)))
($ state 'copper)))))))
(('give-electron) ($ electron? #t))
(('alive?) #t)
@ -267,7 +277,8 @@
(('describe) `(gem ,position))
(('collide other offset grid-info)
(when (eq? ($ other 'type) 'player)
($ picked-up? #t)))))
($ picked-up? #t)
($ grid-info 'append-event `(pickup ,x ,y))))))
(define (^ghost-gem bcom x y)
(define position (vector x y 1))
@ -294,6 +305,7 @@
(('post-tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
;; TODO: Send grid-info
(('activate) ($ open? #t))
(('deactivate) ($ open? #f))
(('wire-state grid-info) #f)
@ -419,7 +431,6 @@
(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)
(('position) ($ position))
@ -434,7 +445,6 @@
(('tick grid-info)
(match ($ position)
(#(x y z)
($ event #f)
(match ($ velocity)
(#(dx dy)
($ position (vector (+ x dx) (+ y dy) z))
@ -453,7 +463,7 @@
;; Ouch, a gate closed on the player!
(unless ($ obj 'open?)
($ alive? #f)
($ event '(die))))
($ grid-info 'append-event `(player-death ,x ,y))))
(_ (lp rest)))))))))
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
@ -461,35 +471,44 @@
(('alive?) ($ alive?))
(('describe) `(player ,($ position), ($ alive?)))
(('collide other offset grid-info)
(define (reverse-move)
(match ($ position)
(#(x y z)
(match ($ position)
(#(x y z)
(define (reverse-move)
(match offset
(#(dx dy)
($ position (vector (- x dx) (- y dy) z)))))))
(match ($ other 'type)
('exit ($ event '(exit)))
('block
(if ($ other 'pushed?)
($ event '(push))
(begin
(reverse-move)
($ event '(bump)))))
('switch ($ event '(switch)))
('gem ($ event '(gem)))
('ghost-gem #t)
('gate
(unless ($ other 'open?)
(reverse-move)
($ event '(bump))))
(_
(reverse-move)
($ event '(bump)))))
(('event) ($ event))))
($ position (vector (- x dx) (- y dy) z)))))
(match ($ other 'type)
('exit
($ grid-info 'append-event `(exit ,x ,y)))
('block
(if ($ other 'pushed?)
($ grid-info 'append-event `(push ,x ,y))
(begin
(reverse-move)
($ grid-info 'append-event `(bump ,x ,y)))))
((or 'gem 'switch 'ghost-gem) #t)
('gate
(unless ($ other 'open?)
(reverse-move)
($ grid-info 'append-event `(bump ,x ,y))))
(_
(reverse-move)
($ grid-info 'append-event `(bump ,x ,y)))))))))
(define (^event-log bcom)
(define events (spawn ^cell '()))
(match-lambda*
(('append event)
($ events (cons event ($ events))))
(('flush)
(let ((result (reverse ($ events))))
($ events '())
result))))
(define (^level bcom width height)
(define player (spawn ^cell))
(define objects (spawn ^cell '()))
(define event-log (spawn ^event-log))
;; Spatial partition
(define (for-each-coord proc)
@ -569,7 +588,9 @@
(('wireworld-neighbor-count x y)
(neighbor-count x y))
(('wireworld-neighbor-grid x y)
(neighbor-grid x y))))
(neighbor-grid x y))
(('append-event event)
($ event-log 'append event))))
(define grid-info (spawn ^grid-info))
(define (delq item lst)
@ -667,4 +688,6 @@
(match ($ obj 'position)
(#(x y _)
(let ((cell (grid-ref grid x y)))
($ cell (cons obj ($ cell)))))))))
($ cell (cons obj ($ cell)))))))
(('flush-events)
($ event-log 'flush))))