From eeb95785c7ba49ca16abc39437dc6b66f0fc478f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 26 May 2024 12:35:46 -0400
Subject: [PATCH] Fix desync between fade out/in and level loading when game is
 lagging.

---
 Makefile                 |  1 +
 game.scm                 | 15 +++++++++------
 modules/game/effects.scm | 15 +++++++++++++--
 modules/game/scripts.scm | 20 ++++++++++----------
 4 files changed, 33 insertions(+), 18 deletions(-)

diff --git a/Makefile b/Makefile
index 9d5e55d..91b4ce3 100644
--- a/Makefile
+++ b/Makefile
@@ -9,6 +9,7 @@ modules = \
   modules/game/actors.scm \
   modules/game/effects.scm \
   modules/game/level.scm \
+  modules/game/scripts.scm \
   modules/game/tileset.scm \
   modules/game/time.scm \
   modules/game/animation.scm \
diff --git a/game.scm b/game.scm
index be7ce71..af880de 100644
--- a/game.scm
+++ b/game.scm
@@ -231,8 +231,9 @@
           (run-script
            (lambda ()
              (set! *state* 'interstitial)
-             (show-effect! (make-fade-out+in-effect 1.0))
-             (wait 30)                  ; ~half the effect time
+             (yield
+              (lambda (k)
+                (show-effect! (make-fade-out+in-effect 1.0 k))))
              (load-level! idx))))
         (begin
           (run-script
@@ -240,8 +241,9 @@
              (set! *level-idx* 0)
              (save-game!)
              (set! *state* 'interstitial)
-             (show-effect! (make-fade-out+in-effect 2.0))
-             (wait 60)
+             (yield
+              (lambda (k)
+                (show-effect! (make-fade-out+in-effect 2.0 k))))
              (load-credits!)))))))
 
 ;; Auto-save/load to local storage.
@@ -270,8 +272,9 @@
      (set! *level-idx* 0)
      (save-game!)
      (set! *state* 'interstitial)
-     (show-effect! (make-fade-out+in-effect 2.0))
-     (wait 60)
+     (yield
+      (lambda (k)
+        (show-effect! (make-fade-out+in-effect 2.0 k))))
      (load-level! 0))))
 
 ;; Update loop
diff --git a/modules/game/effects.scm b/modules/game/effects.scm
index bf93c4e..79aafe9 100644
--- a/modules/game/effects.scm
+++ b/modules/game/effects.scm
@@ -1,5 +1,6 @@
 (define-module (game effects)
   #:use-module (dom canvas)
+  #:use-module (game scripts)
   #:use-module (game time)
   #:use-module (ice-9 match)
   #:use-module (math)
@@ -57,11 +58,21 @@
 (define game-width 320.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)
     (if (< t 0.5)
         (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")
     (fill-rect context 0.0 0.0 game-width game-height)
     (set-global-alpha! context 1.0))
diff --git a/modules/game/scripts.scm b/modules/game/scripts.scm
index 107c04b..1ad646e 100644
--- a/modules/game/scripts.scm
+++ b/modules/game/scripts.scm
@@ -7,6 +7,7 @@
             script?
             run-script
             script-cancel!
+            yield
             wait
             forever
             tween)
@@ -102,9 +103,8 @@
                          (current-scheduler scheduler))
             (thunk)))
         handler)))
-  (define (handler k delay)
-    (when delay
-      (scheduler-add! scheduler (lambda () (run k)) delay)))
+  (define (handler k proc)
+    (proc (lambda () (run k))))
   (when (script-pending? script)
     (let ((parent (current-script)))
       (when parent
@@ -112,20 +112,20 @@
     (run
      (lambda ()
        (set-script-state! script 'running)
-       ((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)))))
+       ((script-cont script))))))
 
 (define (run-script thunk)
   (let ((script (make-script thunk)))
     (script-run! script)
     script))
 
+(define (yield proc)
+  (abort-to-prompt %script-tag proc))
+
 (define (wait delay)
-  (abort-to-prompt %script-tag delay))
+  (yield
+   (lambda (thunk)
+     (scheduler-add! (current-scheduler) thunk delay))))
 
 (define-syntax-rule (forever body ...)
   (let loop ()