Fix desync between fade out/in and level loading when game is lagging.

This commit is contained in:
David Thompson 2024-05-26 12:35:46 -04:00
parent 78ce020fcb
commit eeb95785c7
4 changed files with 33 additions and 18 deletions

View file

@ -9,6 +9,7 @@ modules = \
modules/game/actors.scm \ modules/game/actors.scm \
modules/game/effects.scm \ modules/game/effects.scm \
modules/game/level.scm \ modules/game/level.scm \
modules/game/scripts.scm \
modules/game/tileset.scm \ modules/game/tileset.scm \
modules/game/time.scm \ modules/game/time.scm \
modules/game/animation.scm \ modules/game/animation.scm \

View file

@ -231,8 +231,9 @@
(run-script (run-script
(lambda () (lambda ()
(set! *state* 'interstitial) (set! *state* 'interstitial)
(show-effect! (make-fade-out+in-effect 1.0)) (yield
(wait 30) ; ~half the effect time (lambda (k)
(show-effect! (make-fade-out+in-effect 1.0 k))))
(load-level! idx)))) (load-level! idx))))
(begin (begin
(run-script (run-script
@ -240,8 +241,9 @@
(set! *level-idx* 0) (set! *level-idx* 0)
(save-game!) (save-game!)
(set! *state* 'interstitial) (set! *state* 'interstitial)
(show-effect! (make-fade-out+in-effect 2.0)) (yield
(wait 60) (lambda (k)
(show-effect! (make-fade-out+in-effect 2.0 k))))
(load-credits!))))))) (load-credits!)))))))
;; Auto-save/load to local storage. ;; Auto-save/load to local storage.
@ -270,8 +272,9 @@
(set! *level-idx* 0) (set! *level-idx* 0)
(save-game!) (save-game!)
(set! *state* 'interstitial) (set! *state* 'interstitial)
(show-effect! (make-fade-out+in-effect 2.0)) (yield
(wait 60) (lambda (k)
(show-effect! (make-fade-out+in-effect 2.0 k))))
(load-level! 0)))) (load-level! 0))))
;; Update loop ;; Update loop

View file

@ -1,5 +1,6 @@
(define-module (game effects) (define-module (game effects)
#:use-module (dom canvas) #:use-module (dom canvas)
#:use-module (game scripts)
#:use-module (game time) #:use-module (game time)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (math) #:use-module (math)
@ -57,11 +58,21 @@
(define game-width 320.0) (define game-width 320.0)
(define game-height 240.0) (define game-height 240.0)
(define (make-fade-out+in-effect duration) ;; on-transition is a last-minute hack to make it possible to sync the
;; loading of the next level with the moment when the screen is
;; completely black.
(define (make-fade-out+in-effect duration on-transition)
(define transitioned? #f)
(define (maybe-transition)
(unless transitioned?
(set! transitioned? #t)
(on-transition)))
(define (draw context t) (define (draw context t)
(if (< t 0.5) (if (< t 0.5)
(set-global-alpha! context (* t 2.0)) (set-global-alpha! context (* t 2.0))
(set-global-alpha! context (- 1.0 (* (- t 0.5) 2.0)))) (begin
(maybe-transition)
(set-global-alpha! context (- 1.0 (* (- t 0.5) 2.0)))))
(set-fill-color! context "#000000") (set-fill-color! context "#000000")
(fill-rect context 0.0 0.0 game-width game-height) (fill-rect context 0.0 0.0 game-width game-height)
(set-global-alpha! context 1.0)) (set-global-alpha! context 1.0))

View file

@ -7,6 +7,7 @@
script? script?
run-script run-script
script-cancel! script-cancel!
yield
wait wait
forever forever
tween) tween)
@ -102,9 +103,8 @@
(current-scheduler scheduler)) (current-scheduler scheduler))
(thunk))) (thunk)))
handler))) handler)))
(define (handler k delay) (define (handler k proc)
(when delay (proc (lambda () (run k))))
(scheduler-add! scheduler (lambda () (run k)) delay)))
(when (script-pending? script) (when (script-pending? script)
(let ((parent (current-script))) (let ((parent (current-script)))
(when parent (when parent
@ -112,20 +112,20 @@
(run (run
(lambda () (lambda ()
(set-script-state! script 'running) (set-script-state! script 'running)
((script-cont script)) ((script-cont script))))))
;; Nasty hack: For some reason, falling through the prompt
;; thunk messes up the Scheme stack, resulting in an invalid
;; ref.cast somewhere. So, we *never* fall through. Instead,
;; we create a continuation that gets thrown away.
(abort-to-prompt %script-tag #f)))))
(define (run-script thunk) (define (run-script thunk)
(let ((script (make-script thunk))) (let ((script (make-script thunk)))
(script-run! script) (script-run! script)
script)) script))
(define (yield proc)
(abort-to-prompt %script-tag proc))
(define (wait delay) (define (wait delay)
(abort-to-prompt %script-tag delay)) (yield
(lambda (thunk)
(scheduler-add! (current-scheduler) thunk delay))))
(define-syntax-rule (forever body ...) (define-syntax-rule (forever body ...)
(let loop () (let loop ()