1 ;;; -*- mode: scheme; coding: utf-8; -*-
3 ;;; Examples for Eager Comprehensions in [outer..inner|expr]-Convention
4 ;;; ===================================================================
6 ;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
7 ;;; Copyright (c) 2007 Sebastian Egner
9 ;;; This code is based on the file examples.scm in the reference
10 ;;; implementation of SRFI-42, provided under the following license:
12 ;;; Permission is hereby granted, free of charge, to any person obtaining
13 ;;; a copy of this software and associated documentation files (the
14 ;;; ``Software''), to deal in the Software without restriction, including
15 ;;; without limitation the rights to use, copy, modify, merge, publish,
16 ;;; distribute, sublicense, and/or sell copies of the Software, and to
17 ;;; permit persons to whom the Software is furnished to do so, subject to
18 ;;; the following conditions:
20 ;;; The above copyright notice and this permission notice shall be
21 ;;; included in all copies or substantial portions of the Software.
23 ;;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
24 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
25 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
26 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
27 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
28 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
29 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
32 (define-module (test-srfi-42)
33 #:use-module (test-suite lib)
34 #:use-module (srfi srfi-42))
37 ; Tools for checking results
38 ; ==========================
40 (define (my-equal? x y)
50 (and (string? y) (string=? x y)) )
53 (my-equal? (vector->list x) (vector->list y)) ))
56 (my-equal? (car x) (car y))
57 (my-equal? (cdr x) (cdr y)) ))
60 (eqv? (exact? x) (exact? y))
63 (< (abs (- x y)) (/ 1 (expt 10 6))) ))) ; will do here
65 (error "unrecognized type" x) )))
67 (define-syntax my-check
69 ((my-check ec => desired-result)
70 (pass-if (my-equal? ec desired-result)))))
72 (define my-call-with-input-file call-with-input-file)
73 (define my-open-output-file open-output-file)
75 ; ==========================================================================
77 ; ==========================================================================
80 (let ((x 0)) (do-ec (set! x (+ x 1))) x)
84 (let ((x 0)) (do-ec (:range i 10) (set! x (+ x 1))) x)
88 (let ((x 0)) (do-ec (:range n 10) (:range k n) (set! x (+ x 1))) x)
92 ; ==========================================================================
93 ; list-ec and basic qualifiers
94 ; ==========================================================================
96 (my-check (list-ec 1) => '(1))
98 (my-check (list-ec (:range i 4) i) => '(0 1 2 3))
100 (my-check (list-ec (:range n 3) (:range k (+ n 1)) (list n k))
101 => '((0 0) (1 0) (1 1) (2 0) (2 1) (2 2)) )
104 (list-ec (:range n 5) (if (even? n)) (:range k (+ n 1)) (list n k))
105 => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
108 (list-ec (:range n 5) (not (even? n)) (:range k (+ n 1)) (list n k))
109 => '((1 0) (1 1) (3 0) (3 1) (3 2) (3 3)) )
112 (list-ec (:range n 5)
113 (and (even? n) (> n 2))
116 => '((4 0) (4 1) (4 2) (4 3) (4 4)) )
119 (list-ec (:range n 5)
120 (or (even? n) (> n 3))
123 => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
126 (let ((x 0)) (list-ec (:range n 10) (begin (set! x (+ x 1))) n) x)
130 (list-ec (nested (:range n 3) (:range k n)) k)
134 ; ==========================================================================
135 ; Other comprehensions
136 ; ==========================================================================
138 (my-check (append-ec '(a b)) => '(a b))
139 (my-check (append-ec (:range i 0) '(a b)) => '())
140 (my-check (append-ec (:range i 1) '(a b)) => '(a b))
141 (my-check (append-ec (:range i 2) '(a b)) => '(a b a b))
143 (my-check (string-ec #\a) => (string #\a))
144 (my-check (string-ec (:range i 0) #\a) => "")
145 (my-check (string-ec (:range i 1) #\a) => "a")
146 (my-check (string-ec (:range i 2) #\a) => "aa")
148 (my-check (string-append-ec "ab") => "ab")
149 (my-check (string-append-ec (:range i 0) "ab") => "")
150 (my-check (string-append-ec (:range i 1) "ab") => "ab")
151 (my-check (string-append-ec (:range i 2) "ab") => "abab")
153 (my-check (vector-ec 1) => (vector 1))
154 (my-check (vector-ec (:range i 0) i) => (vector))
155 (my-check (vector-ec (:range i 1) i) => (vector 0))
156 (my-check (vector-ec (:range i 2) i) => (vector 0 1))
158 (my-check (vector-of-length-ec 1 1) => (vector 1))
159 (my-check (vector-of-length-ec 0 (:range i 0) i) => (vector))
160 (my-check (vector-of-length-ec 1 (:range i 1) i) => (vector 0))
161 (my-check (vector-of-length-ec 2 (:range i 2) i) => (vector 0 1))
163 (my-check (sum-ec 1) => 1)
164 (my-check (sum-ec (:range i 0) i) => 0)
165 (my-check (sum-ec (:range i 1) i) => 0)
166 (my-check (sum-ec (:range i 2) i) => 1)
167 (my-check (sum-ec (:range i 3) i) => 3)
169 (my-check (product-ec 1) => 1)
170 (my-check (product-ec (:range i 1 0) i) => 1)
171 (my-check (product-ec (:range i 1 1) i) => 1)
172 (my-check (product-ec (:range i 1 2) i) => 1)
173 (my-check (product-ec (:range i 1 3) i) => 2)
174 (my-check (product-ec (:range i 1 4) i) => 6)
176 (my-check (min-ec 1) => 1)
177 (my-check (min-ec (:range i 1) i) => 0)
178 (my-check (min-ec (:range i 2) i) => 0)
180 (my-check (max-ec 1) => 1)
181 (my-check (max-ec (:range i 1) i) => 0)
182 (my-check (max-ec (:range i 2) i) => 1)
184 (my-check (first-ec #f 1) => 1)
185 (my-check (first-ec #f (:range i 0) i) => #f)
186 (my-check (first-ec #f (:range i 1) i) => 0)
187 (my-check (first-ec #f (:range i 2) i) => 0)
191 (first-ec #f (:range i 10) (begin (set! last-i i)) i)
195 (my-check (last-ec #f 1) => 1)
196 (my-check (last-ec #f (:range i 0) i) => #f)
197 (my-check (last-ec #f (:range i 1) i) => 0)
198 (my-check (last-ec #f (:range i 2) i) => 1)
200 (my-check (any?-ec #f) => #f)
201 (my-check (any?-ec #t) => #t)
202 (my-check (any?-ec (:range i 2 2) (even? i)) => #f)
203 (my-check (any?-ec (:range i 2 3) (even? i)) => #t)
205 (my-check (every?-ec #f) => #f)
206 (my-check (every?-ec #t) => #t)
207 (my-check (every?-ec (:range i 2 2) (even? i)) => #t)
208 (my-check (every?-ec (:range i 2 3) (even? i)) => #t)
209 (my-check (every?-ec (:range i 2 4) (even? i)) => #f)
212 (let ((sum-sqr (lambda (x result) (+ result (* x x)))))
213 (fold-ec 0 (:range i 10) i sum-sqr) )
217 (let ((minus-1 (lambda (x) (- x 1)))
218 (sum-sqr (lambda (x result) (+ result (* x x)))))
219 (fold3-ec (error "wrong") (:range i 10) i minus-1 sum-sqr) )
223 (fold3-ec 'infinity (:range i 0) i min min)
227 ; ==========================================================================
229 ; ==========================================================================
231 (my-check (list-ec (:list x '()) x) => '())
232 (my-check (list-ec (:list x '(1)) x) => '(1))
233 (my-check (list-ec (:list x '(1 2 3)) x) => '(1 2 3))
234 (my-check (list-ec (:list x '(1) '(2)) x) => '(1 2))
235 (my-check (list-ec (:list x '(1) '(2) '(3)) x) => '(1 2 3))
237 (my-check (list-ec (:string c "") c) => '())
238 (my-check (list-ec (:string c "1") c) => '(#\1))
239 (my-check (list-ec (:string c "123") c) => '(#\1 #\2 #\3))
240 (my-check (list-ec (:string c "1" "2") c) => '(#\1 #\2))
241 (my-check (list-ec (:string c "1" "2" "3") c) => '(#\1 #\2 #\3))
243 (my-check (list-ec (:vector x (vector)) x) => '())
244 (my-check (list-ec (:vector x (vector 1)) x) => '(1))
245 (my-check (list-ec (:vector x (vector 1 2 3)) x) => '(1 2 3))
246 (my-check (list-ec (:vector x (vector 1) (vector 2)) x) => '(1 2))
248 (list-ec (:vector x (vector 1) (vector 2) (vector 3)) x)
251 (my-check (list-ec (:range x -2) x) => '())
252 (my-check (list-ec (:range x -1) x) => '())
253 (my-check (list-ec (:range x 0) x) => '())
254 (my-check (list-ec (:range x 1) x) => '(0))
255 (my-check (list-ec (:range x 2) x) => '(0 1))
257 (my-check (list-ec (:range x 0 3) x) => '(0 1 2))
258 (my-check (list-ec (:range x 1 3) x) => '(1 2))
259 (my-check (list-ec (:range x -2 -1) x) => '(-2))
260 (my-check (list-ec (:range x -2 -2) x) => '())
262 (my-check (list-ec (:range x 1 5 2) x) => '(1 3))
263 (my-check (list-ec (:range x 1 6 2) x) => '(1 3 5))
264 (my-check (list-ec (:range x 5 1 -2) x) => '(5 3))
265 (my-check (list-ec (:range x 6 1 -2) x) => '(6 4 2))
267 (my-check (list-ec (:real-range x 0.0 3.0) x) => '(0. 1. 2.))
268 (my-check (list-ec (:real-range x 0 3.0) x) => '(0. 1. 2.))
269 (my-check (list-ec (:real-range x 0 3 1.0) x) => '(0. 1. 2.))
272 (string-ec (:char-range c #\a #\z) c)
273 => "abcdefghijklmnopqrstuvwxyz" )
277 (let ((f (my-open-output-file "tmp1")))
278 (do-ec (:range n 10) (begin (write n f) (newline f)))
279 (close-output-port f))
280 (my-call-with-input-file "tmp1"
281 (lambda (port) (list-ec (:port x port read) x)) ))
282 => (list-ec (:range n 10) n) )
286 (let ((f (my-open-output-file "tmp1")))
287 (do-ec (:range n 10) (begin (write n f) (newline f)))
288 (close-output-port f))
289 (my-call-with-input-file "tmp1"
290 (lambda (port) (list-ec (:port x port) x)) ))
291 => (list-ec (:range n 10) n) )
294 ; ==========================================================================
295 ; The special generators :do :let :parallel :while :until
296 ; ==========================================================================
298 (my-check (list-ec (:do ((i 0)) (< i 4) ((+ i 1))) i) => '(0 1 2 3))
311 (my-check (list-ec (:let x 1) x) => '(1))
312 (my-check (list-ec (:let x 1) (:let y (+ x 1)) y) => '(2))
313 (my-check (list-ec (:let x 1) (:let x (+ x 1)) x) => '(2))
316 (list-ec (:parallel (:range i 1 10) (:list x '(a b c))) (list i x))
317 => '((1 a) (2 b) (3 c)) )
320 (list-ec (:while (:range i 1 10) (< i 5)) i)
324 (list-ec (:until (:range i 1 10) (>= i 5)) i)
327 ; with generator that might use inner bindings
330 (list-ec (:while (:list i '(1 2 3 4 5 6 7 8 9)) (< i 5)) i)
332 ; Was broken in original reference implementation as pointed
333 ; out by sunnan@handgranat.org on 24-Apr-2005 comp.lang.scheme.
334 ; Refer to http://groups-beta.google.com/group/comp.lang.scheme/
335 ; browse_thread/thread/f5333220eaeeed66/75926634cf31c038#75926634cf31c038
338 (list-ec (:until (:list i '(1 2 3 4 5 6 7 8 9)) (>= i 5)) i)
342 (list-ec (:while (:vector x (index i) '#(1 2 3 4 5))
346 ; Was broken in reference implementation, even after fix for the
347 ; bug reported by Sunnan, as reported by Jens-Axel Soegaard on
350 ; combine :while/:until and :parallel
353 (list-ec (:while (:parallel (:range i 1 10)
354 (:list j '(1 2 3 4 5 6 7 8 9)))
357 => '((1 1) (2 2) (3 3) (4 4)))
360 (list-ec (:until (:parallel (:range i 1 10)
361 (:list j '(1 2 3 4 5 6 7 8 9)))
364 => '((1 1) (2 2) (3 3) (4 4) (5 5)))
366 ; check that :while/:until really stop the generator
370 (do-ec (:while (:range i 1 10) (begin (set! n (+ n 1)) (< i 5)))
377 (do-ec (:until (:range i 1 10) (begin (set! n (+ n 1)) (>= i 5)))
384 (do-ec (:while (:parallel (:range i 1 10)
385 (:do () (begin (set! n (+ n 1)) #t) ()))
393 (do-ec (:until (:parallel (:range i 1 10)
394 (:do () (begin (set! n (+ n 1)) #t) ()))
400 ; ==========================================================================
401 ; The dispatching generator
402 ; ==========================================================================
404 (my-check (list-ec (: c '(a b)) c) => '(a b))
405 (my-check (list-ec (: c '(a b) '(c d)) c) => '(a b c d))
407 (my-check (list-ec (: c "ab") c) => '(#\a #\b))
408 (my-check (list-ec (: c "ab" "cd") c) => '(#\a #\b #\c #\d))
410 (my-check (list-ec (: c (vector 'a 'b)) c) => '(a b))
411 (my-check (list-ec (: c (vector 'a 'b) (vector 'c)) c) => '(a b c))
413 (my-check (list-ec (: i 0) i) => '())
414 (my-check (list-ec (: i 1) i) => '(0))
415 (my-check (list-ec (: i 10) i) => '(0 1 2 3 4 5 6 7 8 9))
416 (my-check (list-ec (: i 1 2) i) => '(1))
417 (my-check (list-ec (: i 1 2 3) i) => '(1))
418 (my-check (list-ec (: i 1 9 3) i) => '(1 4 7))
420 (my-check (list-ec (: i 0.0 1.0 0.2) i) => '(0. 0.2 0.4 0.6 0.8))
422 (my-check (list-ec (: c #\a #\c) c) => '(#\a #\b #\c))
426 (let ((f (my-open-output-file "tmp1")))
427 (do-ec (:range n 10) (begin (write n f) (newline f)))
428 (close-output-port f))
429 (my-call-with-input-file "tmp1"
430 (lambda (port) (list-ec (: x port read) x)) ))
431 => (list-ec (:range n 10) n) )
435 (let ((f (my-open-output-file "tmp1")))
436 (do-ec (:range n 10) (begin (write n f) (newline f)))
437 (close-output-port f))
438 (my-call-with-input-file "tmp1"
439 (lambda (port) (list-ec (: x port) x)) ))
440 => (list-ec (:range n 10) n) )
443 ; ==========================================================================
444 ; With index variable
445 ; ==========================================================================
447 (my-check (list-ec (:list c (index i) '(a b)) (list c i)) => '((a 0) (b 1)))
448 (my-check (list-ec (:string c (index i) "a") (list c i)) => '((#\a 0)))
449 (my-check (list-ec (:vector c (index i) (vector 'a)) (list c i)) => '((a 0)))
452 (list-ec (:range i (index j) 0 -3 -1) (list i j))
453 => '((0 0) (-1 1) (-2 2)) )
456 (list-ec (:real-range i (index j) 0 1 0.2) (list i j))
457 => '((0. 0) (0.2 1) (0.4 2) (0.6 3) (0.8 4)) )
460 (list-ec (:char-range c (index i) #\a #\c) (list c i))
461 => '((#\a 0) (#\b 1) (#\c 2)) )
464 (list-ec (: x (index i) '(a b c d)) (list x i))
465 => '((a 0) (b 1) (c 2) (d 3)) )
469 (let ((f (my-open-output-file "tmp1")))
470 (do-ec (:range n 10) (begin (write n f) (newline f)))
471 (close-output-port f))
472 (my-call-with-input-file "tmp1"
473 (lambda (port) (list-ec (: x (index i) port) (list x i))) ))
474 => '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)) )
477 ; ==========================================================================
478 ; The examples from the SRFI document
479 ; ==========================================================================
483 (my-check (list-ec (: i 5) (* i i)) => '(0 1 4 9 16))
486 (list-ec (: n 1 4) (: i n) (list n i))
487 => '((1 0) (2 0) (2 1) (3 0) (3 1) (3 2)) )
492 (list-ec (: x (index i) "abc") (list x i))
493 => '((#\a 0) (#\b 1) (#\c 2)) )
496 (list-ec (:string c (index i) "a" "b") (cons c i))
497 => '((#\a . 0) (#\b . 1)) )
500 ; ==========================================================================
501 ; Little Shop of Horrors
502 ; ==========================================================================
504 (my-check (list-ec (:range x 5) (:range x x) x) => '(0 0 1 0 1 2 0 1 2 3))
506 (my-check (list-ec (:list x '(2 "23" (4))) (: y x) y) => '(0 1 #\2 #\3 4))
509 (list-ec (:parallel (:integers x)
510 (:do ((i 10)) (< x i) ((- i 1))))
512 => '((0 10) (1 9) (2 8) (3 7) (4 6)) )
515 ; ==========================================================================
516 ; Less artificial examples
517 ; ==========================================================================
519 (define (factorial n) ; n * (n-1) * .. * 1 for n >= 0
520 (product-ec (:range k 2 (+ n 1)) k) )
522 (my-check (factorial 0) => 1)
523 (my-check (factorial 1) => 1)
524 (my-check (factorial 3) => 6)
525 (my-check (factorial 5) => 120)
528 (define (eratosthenes n) ; primes in {2..n-1} for n >= 1
529 (let ((p? (make-string n #\1)))
530 (do-ec (:range k 2 n)
531 (if (char=? (string-ref p? k) #\1))
532 (:range i (* 2 k) n k)
533 (string-set! p? i #\0) )
534 (list-ec (:range k 2 n) (if (char=? (string-ref p? k) #\1)) k) ))
538 => '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) )
541 (length (eratosthenes 100000))
542 => 9592 ) ; we expect 10^5/ln(10^5)
545 (define (pythagoras n) ; a, b, c s.t. 1 <= a <= b <= c <= n, a^2 + b^2 = c^2
549 ; (begin (display a) (display " "))
552 (:let sqr-c (+ sqr-a (* b b)))
553 (if (<= sqr-c sqr-n))
555 (if (= (* c c) sqr-c))
560 => '((3 4 5) (5 12 13) (6 8 10) (9 12 15)) )
563 (length (pythagoras 200))
567 (define (qsort xs) ; stable
570 (let ((pivot (car xs)) (xrest (cdr xs)))
572 (qsort (list-ec (:list x xrest) (if (< x pivot)) x))
574 (qsort (list-ec (:list x xrest) (if (>= x pivot)) x)) ))))
577 (qsort '(1 5 4 2 4 5 3 2 1 3))
578 => '(1 1 2 2 3 3 4 4 5 5) )
581 (define (pi-BBP m) ; approx. of pi within 16^-m (Bailey-Borwein-Plouffe)
589 (/ 1 (expt 16 n)) )))
593 => (/ 40413742330349316707 12864093722915635200) )
596 (define (read-line port) ; next line (incl. #\newline) of port
599 (:until (:port c port read-char)
600 (char=? c #\newline) )
602 (if (string=? line "")
603 (read-char port) ; eof-object
606 (define (read-lines filename) ; list of all lines
607 (my-call-with-input-file
610 (list-ec (:port line port read-line) line) )))
614 (let ((f (my-open-output-file "tmp1")))
615 (do-ec (:range n 10) (begin (write n f) (newline f)))
616 (close-output-port f))
617 (read-lines "tmp1") )
618 => (list-ec (:char-range c #\0 #\9) (string c #\newline)) )
620 (false-if-exception (delete-file "tmp1"))