blob: 842e71b08c8e3cb75bd7672d9de0468fd58b24ec (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
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))))))))
|
