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

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