source: project/release/3/F-operator/tests/F-operator-test.scm @ 8904

Last change on this file since 8904 was 8904, checked in by Kon Lovett, 12 years ago

Save.

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