source: project/F-operator/tests/F-operator-test.scm @ 5067

Last change on this file since 5067 was 5067, checked in by Kon Lovett, 13 years ago

Changed to chicken-setup tests directory structure.

File size: 11.1 KB
Line 
1;;;; F-operator-test.scm
2;;;; Kon Lovett, Apr 6 '06
3
4(use testbase testbase-output-human)
5(use shift-reset bshift-breset gshift-greset reflect-reify)
6(use srfi-1)
7
8;; Generated value saving
9
10(define (make-collector)
11  (let ([lst '()])
12    (lambda v
13      (if (null? v)
14        (reverse! lst)
15        (begin
16          (set-cdr! v lst)
17          (set! lst v))))))
18
19;; Monads
20
21(define-unit maybe obj)
22
23(define-bind maybe (and monad (func monad)) )
24
25(define (maybe-foo x)
26  (if (zero? x)
27    (reflect maybe #f)  ; exception
28    (/ 1 x) ) )
29
30(define (maybe-bar x)
31  (+ x x) )
32
33(define (maybe-baz x)
34  (if (zero? x)
35    (reflect maybe #f)
36    (/ 1 x) ) )
37
38(cond-expand [hygienic-macros
39
40;; Generalized shift/reset implementations of some control operators
41
42(define-syntax prompt
43  (syntax-rules ()
44    [(_ e) (greset hr-stop e)]
45  ))
46
47(define-syntax control
48  (syntax-rules ()
49    [(_ f e) (gshift hs-prop f e)]
50  ))
51
52(define-syntax prompt0
53  (syntax-rules ()
54    [(_ e) (greset hr-prop e)]
55  ))
56
57(define-syntax shift0
58  (syntax-rules ()
59    [(_ f e) (gshift hs-stop f e)]
60  ))
61
62][else
63
64;; Generalized shift/reset implementations of some control operators
65
66(define-macro (prompt E)
67  `(greset hr-stop ,E) )
68
69(define-macro (control F E)
70  `(gshift hs-prop ,F ,E) )
71
72(define-macro (prompt0 E)
73  `(greset hr-prop ,E) )
74
75(define-macro (shift0 F E)
76  `(gshift hs-stop ,F ,E) )
77
78])
79
80;;
81
82(define-test shift-reset-test "Shift/Reset Family"
83
84  (test/case "%shift/%reset"
85
86    (expect-eqv 5
87      (+ 1 (%reset (* 2 (%shift k 4)))))
88
89    (expect-eqv 117
90      (+ 10 (%reset (+ 2 (%shift k (+ 100 (k (k 3))))))))
91
92    (expect-eqv 60
93      (* 10 (%reset (* 2 (%shift g (%reset (* 5 (%shift f (+ (f 1) 1)))))))))
94
95    (expect-eqv 121
96      (let ([f (lambda (x) (%shift k (k (k x))))])
97        (+ 1 (%reset (+ 10 (f 100))))))
98
99    (expect-equal '(a)
100      (%reset
101        (let ([x (%shift f (cons 'a (f '())))])
102          (%shift g x))))
103
104    (expect-equal '(a 1 b b c) ; not '(a b 1 b b c)
105      (cons 'a (%reset (cons 'b (%shift f (cons 1 (f (f (cons 'c '())))))))))
106
107    (expect-failure (%shift t 'x))
108  )
109
110  (test/case "shift/reset"
111
112    (expect-eqv 5
113      (+ 1 (reset (* 2 (shift k 4)))))
114
115    (expect-eqv 117
116      (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))
117
118    (expect-eqv 60
119      (* 10 (reset (* 2 (shift g (reset (* 5 (shift f (+ (f 1) 1)))))))))
120
121    (expect-eqv 121
122      (let ([f (lambda (x) (shift k (k (k x))))])
123        (+ 1 (reset (+ 10 (f 100))))))
124
125    (expect-equal '(a)
126      (reset
127        (let ([x (shift f (cons 'a (f '())))])
128          (shift g x))))
129
130    (expect-equal '(a 1 b b c) ; not '(a b 1 b b c)
131      (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c '())))))))))
132
133    (expect-failure (shift t 'x))
134  )
135
136  (test/case "%shift-values/%reset-values"
137
138    (expect-eqv 5
139      (+ 1 (%reset-values (* 2 (%shift-values k 4)))))
140
141    (expect-eqv 117
142      (+ 10 (%reset-values (+ 2 (%shift-values k (+ 100 (k (k 3))))))))
143
144    (expect-eqv 60
145      (* 10 (%reset-values (* 2 (%shift-values g (%reset-values (* 5 (%shift-values f (+ (f 1) 1)))))))))
146
147    (expect-eqv 121
148      (let ([f (lambda (x) (%shift-values k (k (k x))))])
149        (+ 1 (%reset-values (+ 10 (f 100))))))
150
151    (expect-equal '(a)
152      (%reset-values
153        (let ([x (%shift-values f (cons 'a (f '())))])
154          (%shift-values g x))))
155
156    (expect-equal '(a 1 b b c)
157      (cons 'a (%reset-values (cons 'b (%shift-values f (cons 1 (f (f (cons 'c '())))))))))
158
159    (expect-failure (%shift-values t 'x))
160
161    (expect-equal '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
162      (cons 'a
163        (%reset-values
164          (cons 'b
165            (let-values ([(x y) (%shift-values f (cons 1 (f '2 (f 3 '()))))])
166              (cons x y))))))
167  )
168
169  (test/case "shift-values/reset-values"
170
171    (expect-eqv 5
172      (+ 1 (reset-values (* 2 (shift-values k 4)))))
173
174    (expect-eqv 117
175      (+ 10 (reset-values (+ 2 (shift-values k (+ 100 (k (k 3))))))))
176
177    (expect-eqv 60
178      (* 10 (reset-values (* 2 (shift-values g (reset-values (* 5 (shift-values f (+ (f 1) 1)))))))))
179
180    (expect-eqv 121
181      (let ([f (lambda (x) (shift-values k (k (k x))))])
182        (+ 1 (reset-values (+ 10 (f 100))))))
183
184    (expect-equal '(a)
185      (reset-values
186        (let ([x (shift-values f (cons 'a (f '())))])
187          (shift-values g x))))
188
189    (expect-equal '(a 1 b b c)
190      (cons 'a (reset-values (cons 'b (shift-values f (cons 1 (f (f (cons 'c '())))))))))
191
192    (expect-failure (shift-values t 'x))
193
194    (expect-equal '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
195      (cons 'a
196        (reset-values
197          (cons 'b
198            (let-values ([(x y) (shift-values f (cons 1 (f '2 (f 3 '()))))])
199              (cons x y))))))
200  )
201
202  (test/case "%bshift/%breset" (
203      [gather (make-collector)]
204      [fact (lambda (n) (let loop ([n n]) (if (<= n 0) 1 (* n (loop (- n 1))))))]
205    )
206
207    (expect-equal "step 1" '(1 2 6 24 120)
208      (begin
209        (%breset r
210          (gather (fact (%range r 1 5))))
211        (gather)))
212    (expect-set! gather (make-collector))
213
214    (expect-equal "step 2" '(1 6 120 5040 362880 39916800 6227020800)
215      (begin
216        (%breset r
217          (gather (fact (%range r 1 2 14))))
218        (gather)))
219    (expect-set! gather (make-collector))
220
221    (expect-equal "two %ranges" '(101 111 121 102 112 122)
222      (begin
223        (%breset r1
224          (%breset r2 (gather (+ (%range r1 1 2) (%range r2 100 10 120)))))
225        (gather)))
226    (expect-set! gather (make-collector))
227
228    (expect-eqv "collect" 120
229      (%breset r1
230        (%breset r2
231          (%bshift r1 f
232            (let ([n (%range r2 1 5)]
233                  [nprev (f #f)])
234              (* n (if (range-empty? nprev) 1 nprev)))))))
235
236    (expect-equal "%range-collect" '(120 120 60 20 5)
237      (begin
238        (%breset r3
239          (gather
240            (%breset r1
241              (%breset r2
242                (%bshift r1 f
243                  (let ([n (%range r2 (%range r3 1 5) 5)]
244                        [nprev (f #f)])
245                    (* n (if (range-empty? nprev) 1 nprev))))))))
246        (gather)))
247    (expect-set! gather (make-collector))
248
249    (expect-equal '(11 14 17)
250      (begin
251        (%breset r
252          (let* ([k (%range r 1 3 9)]
253                [j (+ 10 k)])
254            (gather j)))
255        (gather)))
256    (expect-set! gather (make-collector))
257
258    (expect-equal '(1 2 3)
259      (begin
260        (%breset out
261          (%breset r
262            (let ([k (%range r 1 4)])
263              (gather k)
264              (when (> k 2)
265                (%bshift out f #f)))))
266        (gather)))
267    (expect-set! gather (make-collector))
268
269    (expect-equal '((2 10) (2 12) (2 14) (2 16) (2 18) (2 20) (4 10) (4 14) (4 18) (4 22) (4 26) (4 30) (4 34) (4 38))
270      (begin
271        (%breset r
272          (let ([k (%range r 1 4)])
273            (%breset inner
274              (let ([j (%range inner 10 k (* 10 k))])
275                (when (odd? k)
276                  (%bshift r f #f))
277                (gather (list k j))))))
278        (gather)))
279    (expect-set! gather (make-collector))
280  )
281
282  (test/case "bshift/breset" (
283      [gather (make-collector)]
284      [fact (lambda (n) (let loop ([n n]) (if (<= n 0) 1 (* n (loop (- n 1))))))]
285    )
286
287    (expect-equal "step 1" '(1 2 6 24 120)
288      (begin
289        (breset r
290          (gather (fact (range r 1 5))))
291        (gather)))
292    (expect-set! gather (make-collector))
293
294    (expect-equal "step 2" '(1 6 120 5040 362880 39916800 6227020800)
295      (begin
296        (breset r
297          (gather (fact (range r 1 2 14))))
298        (gather)))
299    (expect-set! gather (make-collector))
300
301    (expect-equal "two ranges" '(101 111 121 102 112 122)
302      (begin
303        (breset r1
304          (breset r2 (gather (+ (range r1 1 2) (range r2 100 10 120)))))
305        (gather)))
306    (expect-set! gather (make-collector))
307
308    (expect-eqv "collect" 120
309      (breset r1
310        (breset r2
311          (bshift r1 f
312            (let ([n (range r2 1 5)]
313                  [nprev (f #f)])
314              (* n (if (range-empty? nprev) 1 nprev)))))))
315
316    (expect-equal "range-collect" '(120 120 60 20 5)
317      (begin
318        (breset r3
319          (gather
320            (breset r1
321              (breset r2
322                (bshift r1 f
323                  (let ([n (range r2 (range r3 1 5) 5)]
324                        [nprev (f #f)])
325                    (* n (if (range-empty? nprev) 1 nprev))))))))
326        (gather)))
327    (expect-set! gather (make-collector))
328
329    (expect-equal '(11 14 17)
330      (begin
331        (breset r
332          (let* ([k (range r 1 3 9)]
333                [j (+ 10 k)])
334            (gather j)))
335        (gather)))
336    (expect-set! gather (make-collector))
337
338    (expect-equal '(1 2 3)
339      (begin
340        (breset out
341          (breset r
342            (let ([k (range r 1 4)])
343              (gather k)
344              (when (> k 2)
345                (bshift out f #f)))))
346        (gather)))
347    (expect-set! gather (make-collector))
348
349    (expect-equal '((2 10) (2 12) (2 14) (2 16) (2 18) (2 20) (4 10) (4 14) (4 18) (4 22) (4 26) (4 30) (4 34) (4 38))
350      (begin
351        (breset r
352          (let ([k (range r 1 4)])
353            (breset inner
354              (let ([j (range inner 10 k (* 10 k))])
355                (when (odd? k)
356                  (bshift r f #f))
357                (gather (list k j))))))
358        (gather)))
359    (expect-set! gather (make-collector))
360  )
361
362  (test/case "%bshift-values/%breset-values" (
363      [gather (make-collector)]
364      [fact (lambda (n) (let loop ([n n]) (if (<= n 0) 1 (* n (loop (- n 1))))))]
365    )
366
367    (expect-equal '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
368      (cons 'a
369        (%breset-values r
370          (cons 'b
371            (let-values ([(x y) (%bshift-values r f (cons 1 (f '2 (f 3 '()))))])
372              (cons x y))))))
373  )
374
375  (test/case "bshift-values/breset-values" (
376      [gather (make-collector)]
377      [fact (lambda (n) (let loop ([n n]) (if (<= n 0) 1 (* n (loop (- n 1))))))]
378    )
379
380    (expect-equal '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
381      (cons 'a
382        (breset-values r
383          (cons 'b
384            (let-values ([(x y) (bshift-values r f (cons 1 (f '2 (f 3 '()))))])
385              (cons x y))))))
386  )
387
388  (test/case "gshift/greset"
389
390    (expect-eqv 117 (+ 10 (prompt (+ 2 (control k (+ 100 (k (k 3))))))))
391
392    (expect-equal '() (prompt (let ((x (control f (cons 'a (f '()))))) (control g x))))
393
394    (expect-eqv 2 (prompt ((lambda (x) (control l 2)) (control l (+ 1 (l 0))))))
395
396    (expect-equal '(a) (prompt (control f (cons 'a (f '())))))
397
398    (expect-equal '(a) (prompt (let ((x (control f (cons 'a (f '()))))) (control g (g x)))))
399
400    (expect-eqv 117 (+ 10 (prompt0 (+ 2 (control k (+ 100 (k (k 3))))))))
401
402    (expect-equal '() (prompt0 (prompt0 (let ((x (control f (cons 'a (f '()))))) (control g x)))))
403
404    (expect-eqv 117 (+ 10 (prompt0 (+ 2 (shift0 k (+ 100 (k (k 3))))))))
405
406    (expect-equal '() (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))
407
408    (expect-equal '(a) (prompt0 (cons 'a (prompt0 (prompt0 (shift0 f (shift0 g '())))))))
409  )
410
411  (test/case "reflect/reify"
412
413    (expect-equal 0.5
414      (reify maybe
415        (maybe-baz
416          (maybe-bar
417            (reflect maybe
418              (or (reify maybe (maybe-foo 0))
419                (reify maybe (maybe-foo 1))))))))
420  )
421)
422
423(test::for-each (cut test::styler-set! <> test::output-style-human))
424(run-test "Shift Reset Tests")
Note: See TracBrowser for help on using the repository browser.