blob: ffa9b5eef0c4d7bc7118d3dab0626728ebc8fedc (
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
|
;;; Chickadee Game Toolkit
;;; Copyright © 2017, 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define-module (chickadee scripting agenda)
#:use-module (chickadee data heap)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:export (make-agenda
agenda?
current-agenda
with-agenda
agenda-time
update-agenda
clear-agenda
reset-agenda
schedule-at
schedule-after
schedule-every
call-when
at
after
every))
(define-record-type <agenda>
(%make-agenda time queue poll-set)
agenda?
(time %agenda-time set-agenda-time!)
(queue agenda-queue)
(poll-set agenda-poll-set))
(define (task< a b)
(< (car a) (car b)))
(define (make-agenda)
"Return a new task scheduler."
(%make-agenda 0 (make-heap task<) (make-hash-table)))
(define (schedule agenda time thunk)
(when (<= time (%agenda-time agenda))
(error "cannot schedule in the past" time))
(heap-insert! (agenda-queue agenda) (cons time thunk)))
(define (poll agenda pred thunk)
(hashq-set! (agenda-poll-set agenda) pred thunk))
(define (%agenda-clear! agenda)
(heap-clear! (agenda-queue agenda))
(hash-clear! (agenda-poll-set agenda))
*unspecified*)
(define (%update-agenda agenda dt)
(let ((queue (agenda-queue agenda))
(poll-set (agenda-poll-set agenda))
(time (+ (%agenda-time agenda) dt)))
(set-agenda-time! agenda time)
(let loop ()
(when (not (heap-empty? queue))
(match (heap-min queue)
((task-time . thunk)
(when (<= task-time time)
(heap-remove! queue)
(thunk)
(loop))))))
(hash-for-each (lambda (pred thunk)
(when (pred)
(hashq-remove! poll-set pred)
(thunk)))
poll-set)))
(define current-agenda (make-parameter (make-agenda)))
(define-syntax-rule (with-agenda agenda body ...)
(parameterize ((current-agenda agenda))
body ...))
(define (agenda-time)
"Return the current agenda time."
(%agenda-time (current-agenda)))
(define (clear-agenda)
"Remove all scheduled tasks from the current agenda."
(%agenda-clear! (current-agenda)))
(define (reset-agenda)
"Remove all scheduled tasks from the current agenda and reset time
to 0."
(%agenda-clear! (current-agenda))
(set-agenda-time! (current-agenda) 0))
(define (update-agenda dt)
"Advance the current agenda by DT."
(%update-agenda (current-agenda) dt))
(define (schedule-at time thunk)
"Schedule THUNK to be run at TIME."
(schedule (current-agenda) time thunk))
(define (schedule-after delay thunk)
"Schedule THUNK to be run after DELAY."
(schedule (current-agenda) (+ (agenda-time) delay) thunk))
(define* (schedule-every interval thunk #:optional n)
"Schedule THUNK to run every INTERVAL amount of time. Repeat this N
times, or indefinitely if not specified."
(schedule-after interval
(lambda ()
(cond
((not n)
(thunk)
(schedule-every interval thunk))
((> n 0)
(thunk)
(schedule-every interval thunk (- n 1)))))))
(define (call-when pred thunk)
(poll (current-agenda) pred thunk))
(define-syntax-rule (at time body ...)
(schedule-at time (lambda () body ...)))
(define-syntax-rule (after delay body ...)
(schedule-after delay (lambda () body ...)))
(define-syntax every
(syntax-rules ()
((_ (interval n) body ...)
(schedule-every interval (lambda () body ...) n))
((_ interval body ...)
(schedule-every interval (lambda () body ...)))))
|
