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