Add script scheduler and pre/post visual effects system.

Makefile

@@ -7,6 +7,7 @@ modules = \
   modules/dom/media.scm \
   modules/dom/window.scm \
   modules/game/actors.scm \
+  modules/game/effects.scm \
   modules/game/level.scm \
   modules/game/tileset.scm \
   modules/goblins/abstract-types.scm \

game.js

@@ -67,7 +67,8 @@ window.addEventListener("load", async () => {
           fillRect: (ctx, x, y, w, h) => ctx.fillRect(x, y, w, h),
           fillText: (ctx, text, x, y) => ctx.fillText(text, x, y),
           drawImage: (ctx, image, sx, sy, sw, sh, dx, dy, dw, dh) => ctx.drawImage(image, sx, sy, sw, sh, dx, dy, dw, dh),
-          setScale: (ctx, sx, sy) => ctx.scale(sx, sy),
+          scale: (ctx, sx, sy) => ctx.scale(sx, sy),
+          translate: (ctx, x, y) => ctx.translate(x, y),
           setTransform: (ctx, a, b, c, d, e, f) => ctx.setTransform(a, b, c, d, e, f),
           setImageSmoothingEnabled: (ctx, enabled) => ctx.imageSmoothingEnabled = (enabled == 1)
         },

game.scm

@@ -27,11 +27,13 @@
              (dom window)
              (game actors)
              (game audio)
+             (game effects)
              (game level)
              (game levels level-1)
              (game levels level-2)
              (game levels level-3)
              (game levels level-4)
+             (game scripts)
              (game tileset)
              (goblins core)
              (hoot bytevectors)
@@ -172,7 +174,11 @@
     (if (< idx (vector-length levels))
         (begin
           (save-game!)
-          (load-level! idx))
+          (run-script
+           (lambda ()
+             (show-effect! (make-fade-out+in-effect 1.0))
+             (wait 30) ; ~half the effect time
+             (load-level! idx))))
         (set! *state* 'win))))
 
 ;; Auto-save/load to local storage.
@@ -232,8 +238,11 @@
                  (set! *gems* (cons *level-idx* *gems*)))
                 (('emit x y)
                  (play-sound-effect audio:emit))
-                ((or ('gate-open x y) ('gate-close x y))
+                (('gate-open x y)
                  (play-sound-effect audio:gate))
+                (('gate-close x y)
+                 (play-sound-effect audio:gate)
+                 (show-effect! (make-screen-shake-effect 0.05)))
                 ((or ('floor-switch-on x y) ('floor-switch-off x y))
                  (play-sound-effect audio:floor-switch))
                 (('electric-switch-on x y)
@@ -252,11 +261,22 @@
 
 (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
 (define (update)
-  ;; TODO: what kind of work do we need to do each frame?
+  (scheduler-tick! (current-scheduler))
   (timeout update-callback dt))
 (define update-callback (procedure->external update))
 
 ;; Render loop
+(define *current-effect* #f)
+(define (show-effect! effect)
+  (set! *current-effect* effect)
+  (effect-start! effect))
+(define (draw-current-effect type)
+  (when (and *current-effect*
+             (eq? type (effect-type *current-effect*)))
+    (draw-effect context *current-effect*)
+    (unless (effect-started? *current-effect*)
+      (set! *current-effect* #f))))
+
 (define number->string*
   (let ((cache (make-eq-hashtable)))    ; assuming fixnums only
     (lambda (x)
@@ -362,6 +382,9 @@
       (set-text-align! context "center")
       (fill-text context "OUCH... x_x" (/ game-width 2.0) (/ game-height 2.0)))))
 
+(define (draw-interstitial)
+  (draw-level))
+
 (define (draw-win)
   (set-fill-color! context "#000000")
   (set-text-align! context "left")
@@ -370,10 +393,12 @@
 (define (draw prev-time)
   (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
   (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
-  (set-scale! context *canvas-scale* *canvas-scale*)
+  (scale! context *canvas-scale* *canvas-scale*)
+  (draw-current-effect 'pre)
   (match *state*
-    ('play (draw-level))
+    ((or 'play 'interstitial) (draw-level))
     ('win (draw-win)))
+  (draw-current-effect 'post)
   (request-animation-frame draw-callback))
 (define draw-callback (procedure->external draw))
 

modules/dom/canvas.scm

@@ -31,7 +31,8 @@
             fill-rect
             fill-text
             draw-image
-            set-scale!
+            scale!
+            translate!
             set-transform!
             set-image-smoothing-enabled!))
 
@@ -65,8 +66,11 @@
 (define-foreign draw-image
   "canvas" "drawImage"
   (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none)
-(define-foreign set-scale!
+(define-foreign scale!
-  "canvas" "setScale"
+  "canvas" "scale"
+  (ref extern) f64 f64 -> none)
+(define-foreign translate!
+  "canvas" "translate"
   (ref extern) f64 f64 -> none)
 (define-foreign set-transform!
   "canvas" "setTransform"

modules/game/effects.scm

@@ -0,0 +1,76 @@
+(define-module (game effects)
+  #:use-module (dom canvas)
+  #:use-module (ice-9 match)
+  #:use-module (math)
+  #:use-module (srfi srfi-9)
+  #:use-module (scheme time)
+  #:export (ease:smoothstep
+            ease:linear
+
+            make-effect
+            effect?
+            effect-started?
+            effect-type
+            effect-duration
+            effect-start!
+            draw-effect
+
+            make-fade-out+in-effect
+            make-screen-shake-effect))
+
+(define (ease:smoothstep t)
+  (* t t (- 3 (* 2 t))))
+
+(define (ease:linear t) t)
+
+(define (current-time*)
+  (/ (exact->inexact (current-jiffy)) (jiffies-per-second)))
+
+(define-record-type <effect>
+  (%make-effect type draw ease duration start)
+  effect?
+  (type effect-type)
+  (draw effect-draw)
+  (ease effect-ease)
+  (duration effect-duration)
+  (start effect-start set-effect-start!))
+
+(define* (make-effect type duration draw #:optional (ease ease:smoothstep))
+  (%make-effect type draw ease duration #f))
+
+(define (effect-started? effect)
+  (number? (effect-start effect)))
+
+(define (effect-start! effect)
+  (set-effect-start! effect (current-time*)))
+
+(define (draw-effect context effect)
+  (match effect
+    (($ <effect> type draw ease duration start)
+     (when (number? start)
+       (let ((dt (- (current-time*) start)))
+         (if (>= dt duration)
+             (set-effect-start! effect #f)
+             (let ((t (ease (/ dt duration))))
+               (draw context t))))))))
+
+;; Duplicated from game.scm but gotta go fast!!
+(define game-width 320.0)
+(define game-height 240.0)
+
+(define (make-fade-out+in-effect duration)
+  (define (draw context t)
+    (if (< t 0.5)
+        (set-global-alpha! context (pk 'alpha-out (* t 2.0)))
+        (set-global-alpha! context (pk 'alpha-in (- 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))
+  (make-effect 'post duration draw))
+
+(define (make-screen-shake-effect duration)
+  (define (draw context t)
+    (let ((x (round (random)))
+          (y (round (random))))
+      (translate! context x y)))
+  (make-effect 'pre duration draw))

modules/game/scripts.scm

@@ -0,0 +1,143 @@
+(define-module (game scripts)
+  #:export (make-scheduler
+            current-scheduler
+            scheduler-tick!
+            scheduler-reset!
+
+            script?
+            run-script
+            script-cancel!
+            wait
+            forever
+            tween)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9))
+
+(define-record-type <scheduler>
+  (%make-scheduler ticks num-tasks max-tasks tasks)
+  scheduler?
+  (ticks scheduler-ticks set-scheduler-ticks!)
+  (num-tasks scheduler-num-tasks set-scheduler-num-tasks!)
+  (max-tasks scheduler-max-tasks)
+  (tasks scheduler-tasks))
+
+(define (make-scheduler max-tasks)
+  (%make-scheduler 0 0 max-tasks (make-vector max-tasks)))
+
+(define (scheduler-add! scheduler thunk delay)
+  (match scheduler
+    (($ <scheduler> ticks num-tasks max-tasks tasks)
+     (unless (= num-tasks max-tasks)
+       (vector-set! tasks num-tasks (cons (+ ticks delay) thunk))
+       (set-scheduler-num-tasks! scheduler (+ num-tasks 1))))))
+
+(define (scheduler-tick! scheduler)
+  (define (run-thunks thunks)
+    (for-each (lambda (thunk) (thunk)) thunks))
+  (run-thunks
+   (match scheduler
+     (($ <scheduler> ticks num-tasks max-tasks tasks)
+      (let ((t (+ ticks 1)))
+        (let loop ((i 0) (k num-tasks) (to-run '()))
+          (if (< i k)
+              (match (vector-ref tasks i)
+                ((t* . thunk)
+                 (if (<= t* t)
+                     (let ((k* (- k 1)))
+                       (vector-set! tasks i (vector-ref tasks k*))
+                       (vector-set! tasks k* #f)
+                       (loop i k* (cons thunk to-run)))
+                     (loop (+ i 1) k to-run))))
+              (begin
+                (set-scheduler-ticks! scheduler t)
+                (set-scheduler-num-tasks! scheduler k)
+                to-run))))))))
+
+(define (scheduler-reset! scheduler)
+  (match scheduler
+    (($ <scheduler> ticks num-tasks max-tasks tasks)
+     (set-scheduler-ticks! scheduler 0)
+     (set-scheduler-num-tasks! scheduler 0)
+     (do ((i 0 (+ i 1)))
+         ((= i num-tasks))
+       (vector-set! tasks i #f)))))
+
+(define *scheduler* (make-scheduler 100))
+(define current-scheduler (make-parameter *scheduler*))
+(define current-script (make-parameter #f))
+
+(define %script-tag (make-prompt-tag "script"))
+
+(define-record-type <script>
+  (%make-script scheduler state cont children)
+  script?
+  (scheduler script-scheduler set-script-scheduler!)
+  (state script-state set-script-state!)
+  (cont script-cont set-script-cont!)
+  (children script-children set-script-children!))
+
+(define (make-script thunk)
+  (%make-script (current-scheduler) 'pending thunk '()))
+
+(define (script-pending? script)
+  (eq? (script-state script) 'pending))
+
+(define (script-running? script)
+  (eq? (script-state script) 'running))
+
+(define (script-cancelled? script)
+  (eq? (script-state script) 'cancelled))
+
+(define (script-cancel! script)
+  (set-script-state! script 'cancelled)
+  (for-each script-cancel! (script-children script)))
+
+(define (script-run! script)
+  (define scheduler (script-scheduler script))
+  (define (run thunk)
+    (unless (script-cancelled? script)
+      (call-with-prompt %script-tag
+        (lambda ()
+          (parameterize ((current-script script)
+                         (current-scheduler scheduler))
+            (thunk)))
+        handler)))
+  (define (handler k delay)
+    (when delay
+      (scheduler-add! scheduler (lambda () (run k)) delay)))
+  (when (script-pending? script)
+    (let ((parent (current-script)))
+      (when parent
+        (set-script-children! parent (cons script (script-children parent)))))
+    (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)))))
+
+(define (run-script thunk)
+  (let ((script (make-script thunk)))
+    (script-run! script)
+    script))
+
+(define (wait delay)
+  (abort-to-prompt %script-tag delay))
+
+(define-syntax-rule (forever body ...)
+  (let loop ()
+    body ...
+    (loop)))
+
+(define* (tween proc duration start end ease interpolate)
+  (let ((d (exact->inexact duration)))
+    (let loop ((t 0))
+      (if (= t duration)
+          (proc end)
+          (let ((alpha (ease (/ t d))))
+            (proc (interpolate start end alpha))
+            (wait 1)
+            (loop (+ t 1)))))))