blob: c69a7a9bd9f0d9a03baa3b62db31afe3f248178d (
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
|
;;; Chickadee Game Toolkit
;;; Copyright © 2017, 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Chickadee is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Chickadee is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(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 ...)))))
|
