foss-mmo/modules/game/scripts.scm

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