5 (define-module (tests test-core)
6 #:use-module (srfi srfi-64)
8 #:use-module (ice-9 receive)
9 #:use-module (loopy agenda))
17 (test-assert (time-= '(1 . 1) '(1 . 1)))
18 (test-assert (not (time-= '(1 . 1) '(1 . 0))))
19 (test-assert (not (time-= '(0 . 1) '(1 . 1))))
21 (test-assert (time-< '(1 . 1) '(1 . 2)))
22 (test-assert (time-< '(7 . 2) '(8 . 2)))
23 (test-assert (not (time-< '(7 . 2) '(7 . 2))))
24 (test-assert (not (time-< '(7 . 8) '(7 . 2))))
25 (test-assert (not (time-< '(8 . 2) '(7 . 2))))
33 (define (assert-times-expected time-segments expected-times)
34 (test-equal (map time-segment-time time-segments)
37 (define a-proc (const 'a))
38 (define b-proc (const 'b))
39 (define c-proc (const 'c))
40 (define d-proc (const 'd))
41 (define e-proc (const 'e))
42 (define f-proc (const 'f))
44 (define sched (make-schedule))
45 (test-assert (schedule-empty? sched))
47 ;; Add a segment at (10 . 0)
48 (schedule-add! 10 a-proc sched)
49 (test-assert (not (schedule-empty? sched)))
50 (test-equal (length (schedule-segments sched)) 1)
51 (test-equal (time-segment-time (car (schedule-segments sched)))
53 (test-equal (q-length (time-segment-queue (car (schedule-segments sched))))
55 (test-eq (q-front (time-segment-queue (car (schedule-segments sched))))
57 (test-eq (q-rear (time-segment-queue (car (schedule-segments sched))))
59 (test-eq ((q-front (time-segment-queue (car (schedule-segments sched)))))
61 (assert-times-expected (schedule-segments sched)
64 ;; Add another segment at (10 . 0)
65 (schedule-add! '(10 . 0) b-proc sched)
66 (test-assert (not (schedule-empty? sched)))
67 (test-equal (length (schedule-segments sched)) 1)
68 (test-equal (time-segment-time (car (schedule-segments sched)))
70 (test-equal (q-length (time-segment-queue (car (schedule-segments sched))))
72 (test-eq (q-front (time-segment-queue (car (schedule-segments sched))))
74 (test-eq (q-rear (time-segment-queue (car (schedule-segments sched))))
76 (assert-times-expected (schedule-segments sched)
79 ;; Add a segment to (11 . 0), (8 . 1) and (10 . 10)
80 (schedule-add! 11 c-proc sched)
81 (schedule-add! '(8 . 1) d-proc sched)
82 (schedule-add! '(10 . 10) e-proc sched)
83 (test-assert (not (schedule-empty? sched)))
84 (test-equal (length (schedule-segments sched)) 4)
85 (assert-times-expected (schedule-segments sched)
86 '((8 . 1) (10 . 0) (10 . 10) (11 . 0)))
89 (define (test-split-at schedule time expected-before expected-after)
90 (receive (segments-before segments-after)
91 (schedule-segments-split schedule time)
92 (assert-times-expected segments-before expected-before)
93 (assert-times-expected segments-after expected-after)))
95 (test-split-at sched 0
97 '((8 . 1) (10 . 0) (10 . 10) (11 . 0)))
98 (test-split-at sched '(8 . 0)
100 '((8 . 1) (10 . 0) (10 . 10) (11 . 0)))
101 (test-split-at sched '(8 . 1)
103 '((10 . 0) (10 . 10) (11 . 0)))
104 (test-split-at sched 9
106 '((10 . 0) (10 . 10) (11 . 0)))
107 (test-split-at sched 10
109 '((10 . 10) (11 . 0)))
110 (test-split-at sched 9000
111 '((8 . 1) (10 . 0) (10 . 10) (11 . 0))
113 (test-split-at sched '(9000 . 1) ; over nine thousaaaaaaand
114 '((8 . 1) (10 . 0) (10 . 10) (11 . 0))
117 ;; Break off half of those and do some tests on them
118 (define some-extracted
119 (schedule-extract-until! sched 10))
120 (assert-times-expected some-extracted '((8 . 1) (10 . 0)))
121 (assert-times-expected (schedule-segments sched) '((10 . 10) (11 . 0)))
122 (define first-extracted-queue
123 (time-segment-queue (car some-extracted)))
124 (define second-extracted-queue
125 (time-segment-queue (cadr some-extracted)))
126 (test-assert (not (q-empty? first-extracted-queue)))
127 (test-equal ((deq! first-extracted-queue)) 'd)
128 (test-assert (q-empty? first-extracted-queue))
130 (test-assert (not (q-empty? second-extracted-queue)))
131 (test-equal ((deq! second-extracted-queue)) 'a)
132 (test-equal ((deq! second-extracted-queue)) 'b)
133 (test-assert (q-empty? second-extracted-queue))
135 ;; Add one more and test flattening to a queue
136 (test-assert (not (schedule-empty? sched)))
137 (schedule-add! '(10 . 10) f-proc sched)
138 (define remaining-segments
139 (schedule-extract-until! sched '(9000 . 1)))
140 (test-assert (schedule-empty? sched))
141 (define some-queue (make-q))
142 (enq! some-queue (const 'ho-ho))
143 (enq! some-queue (const 'ha-ha))
144 (add-segments-contents-to-queue! remaining-segments some-queue)
145 (test-assert (not (q-empty? some-queue)))
146 (test-equal 'ho-ho ((deq! some-queue)))
147 (test-equal 'ha-ha ((deq! some-queue)))
148 (test-equal 'e ((deq! some-queue)))
149 (test-equal 'f ((deq! some-queue)))
150 (test-equal 'c ((deq! some-queue)))
151 (test-assert (q-empty? some-queue))
155 ;; Run/wrap request stuff
156 ;; ----------------------
158 (let ((wrapped (wrap (+ 1 2))))
159 (test-assert (procedure? wrapped))
160 (test-equal (wrapped) 3))
162 (let ((run-two-squared (run (lambda () (* 2 2)))))
163 (test-assert (run-request? run-two-squared))
164 (test-assert (procedure? (run-request-proc run-two-squared)))
165 (test-equal ((run-request-proc run-two-squared)) 4)
166 (test-eq (run-request-when run-two-squared) #f))
168 (let ((run-two-squared (run (lambda () (* 2 2)) '(88 . 0))))
169 (test-assert (run-request? run-two-squared))
170 (test-assert (procedure? (run-request-proc run-two-squared)))
171 (test-equal ((run-request-proc run-two-squared)) 4)
172 (test-equal (run-request-when run-two-squared) '(88 . 0)))
174 (let ((run-two-squared (run-wrap (* 2 2))))
175 (test-assert (run-request? run-two-squared))
176 (test-assert (procedure? (run-request-proc run-two-squared)))
177 (test-equal ((run-request-proc run-two-squared)) 4)
178 (test-eq (run-request-when run-two-squared) #f))
180 (let ((run-two-squared (run-wrap-at (* 2 2) '(88 . 0))))
181 (test-assert (run-request? run-two-squared))
182 (test-assert (procedure? (run-request-proc run-two-squared)))
183 (test-equal ((run-request-proc run-two-squared)) 4)
184 (test-equal (run-request-when run-two-squared) '(88 . 0)))
193 (let ((messages '()))
194 (lambda* (#:optional message)
195 (if message (set! messages (append messages (list message))))
200 (define speaker (speak-it))
203 (speaker "I'm a dummy\n"))
206 (speaker "I bet I can make you say you're a dummy!\n")
210 (set! speaker (speak-it)) ; reset the speaker
212 (start-agenda (make-agenda #:queue q)
213 (true-after-n-times 2))
214 (test-equal (speaker)
215 '("I bet I can make you say you're a dummy!\n"
218 ;; should only do the first one after one round though
220 (set! speaker (speak-it)) ; reset the speaker
222 (start-agenda (make-agenda #:queue q)
223 (true-after-n-times 1))
224 (test-equal (speaker)
225 '("I bet I can make you say you're a dummy!\n")))