Add script scheduler and pre/post visual effects system.

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!
-  "canvas" "setScale"
+(define-foreign scale!
+  "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)))))))