1 files changed, 147 insertions, 0 deletions
diff --git a/strigoform/scripts.scm b/strigoform/scripts.scm
new file mode 100644
index 0000000..842e71b
--- /dev/null
+++ b/strigoform/scripts.scm
@@ -0,0 +1,147 @@
+(library (strigoform scripts)
+  (export make-scheduler
+          current-scheduler
+          scheduler-tick!
+          scheduler-reset!
+
+          script?
+          run-script
+          script-cancel!
+          wait
+          forever
+          tween)
+  (import (scheme base)
+          (only (hoot control)
+                make-prompt-tag
+                call-with-prompt
+                abort-to-prompt)
+          (hoot match)
+          (only (hoot syntax) define-syntax-rule define*)
+          (strigoform type))
+
+  (define (make-scheduler max-tasks)
+    (vector 0 0 max-tasks (make-vector max-tasks)))
+
+  (define (scheduler-add! scheduler thunk delay)
+    (match scheduler
+      (#(ticks num-tasks max-tasks tasks)
+       (unless (= num-tasks max-tasks)
+         (vector-set! tasks num-tasks (cons (+ ticks delay) thunk))
+         (vector-set! scheduler 1 (+ num-tasks 1))))))
+
+  (define (scheduler-tick! scheduler)
+    (define (run-thunks thunks)
+      (for-each (lambda (thunk) (thunk)) thunks))
+    (run-thunks
+     (match 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
+                  (vector-set! scheduler 0 t)
+                  (vector-set! scheduler 1 k)
+                  to-run))))))))
+
+  (define (scheduler-reset! scheduler)
+    (match scheduler
+      (#(ticks num-tasks max-tasks tasks)
+       (vector-set! scheduler 0 0)
+       (vector-set! scheduler 1 0)
+       (do ((i 0 (+ i 1)))
+           ((= i num-tasks))
+         (vector-set! tasks i #f)))))
+
+  (define *scheduler* (make-scheduler 100))
+  (define current-scheduler
+    (cond-expand
+     (guile-vm #f)
+     (hoot (make-parameter *scheduler*))))
+  (define current-script
+    (cond-expand
+     (guile-vm #f)
+     (hoot (make-parameter #f))))
+
+  (define %script-tag (make-prompt-tag "script"))
+
+  (define-type script
+    %make-script
+    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 (inexact duration)))
+      (let loop ((t 0))
+        (if (= t duration)
+            (proc end)
+            (let ((alpha (ease (/ (inexact t) d))))
+              (proc (interpolate start end alpha))
+              (wait 1)
+              (loop (+ t 1))))))))