143 lines
4.2 KiB
Scheme
143 lines
4.2 KiB
Scheme
(define-module (game scripts)
|
|
#:export (make-scheduler
|
|
current-scheduler
|
|
scheduler-tick!
|
|
scheduler-reset!
|
|
|
|
script?
|
|
run-script
|
|
script-cancel!
|
|
yield
|
|
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 proc)
|
|
(proc (lambda () (run k))))
|
|
(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))))))
|
|
|
|
(define (run-script thunk)
|
|
(let ((script (make-script thunk)))
|
|
(script-run! script)
|
|
script))
|
|
|
|
(define (yield proc)
|
|
(abort-to-prompt %script-tag proc))
|
|
|
|
(define (wait delay)
|
|
(yield
|
|
(lambda (thunk)
|
|
(scheduler-add! (current-scheduler) thunk 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)))))))
|