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

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 \

game.scm

@@ -231,8 +231,9 @@
           (run-script
            (lambda ()
              (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))))
         (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))
+             (yield
-             (wait 60)
+              (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))
+     (yield
-     (wait 60)
+      (lambda (k)
+        (show-effect! (make-fade-out+in-effect 2.0 k))))
      (load-level! 0))))
 
 ;; Update loop

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

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)
+  (define (handler k proc)
-    (when delay
+    (proc (lambda () (run k))))
-      (scheduler-add! scheduler (lambda () (run k)) delay)))
   (when (script-pending? script)
     (let ((parent (current-script)))
       (when parent
@@ -112,20 +112,20 @@
     (run
      (lambda ()
        (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)
   (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 ()