Commit | Line | Data |
---|---|---|
fdc8fd46 AR |
1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
2 | ||
3 | ;;; Examples for Eager Comprehensions in [outer..inner|expr]-Convention | |
4 | ;;; =================================================================== | |
5 | ;;; | |
b4699977 | 6 | ;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc. |
fdc8fd46 AR |
7 | ;;; Copyright (c) 2007 Sebastian Egner |
8 | ;;; | |
9 | ;;; This code is based on the file examples.scm in the reference | |
10 | ;;; implementation of SRFI-42, provided under the following license: | |
11 | ;;; | |
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: | |
19 | ;;; | |
20 | ;;; The above copyright notice and this permission notice shall be | |
21 | ;;; included in all copies or substantial portions of the Software. | |
22 | ;;; | |
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. | |
30 | ;;; | |
31 | ||
32 | (define-module (test-srfi-42) | |
33 | #:use-module (test-suite lib) | |
34 | #:use-module (srfi srfi-42)) | |
35 | ||
36 | ||
37 | ; Tools for checking results | |
38 | ; ========================== | |
39 | ||
40 | (define (my-equal? x y) | |
41 | (cond | |
42 | ((or (boolean? x) | |
43 | (null? x) | |
44 | (symbol? x) | |
45 | (char? x) | |
46 | (input-port? x) | |
47 | (output-port? x) ) | |
48 | (eqv? x y) ) | |
49 | ((string? x) | |
50 | (and (string? y) (string=? x y)) ) | |
51 | ((vector? x) | |
52 | (and (vector? y) | |
53 | (my-equal? (vector->list x) (vector->list y)) )) | |
54 | ((pair? x) | |
55 | (and (pair? y) | |
56 | (my-equal? (car x) (car y)) | |
57 | (my-equal? (cdr x) (cdr y)) )) | |
58 | ((real? x) | |
59 | (and (real? y) | |
60 | (eqv? (exact? x) (exact? y)) | |
61 | (if (exact? x) | |
62 | (= x y) | |
63 | (< (abs (- x y)) (/ 1 (expt 10 6))) ))) ; will do here | |
64 | (else | |
65 | (error "unrecognized type" x) ))) | |
66 | ||
67 | (define-syntax my-check | |
68 | (syntax-rules (=>) | |
69 | ((my-check ec => desired-result) | |
70 | (pass-if (my-equal? ec desired-result))))) | |
71 | ||
72 | (define my-call-with-input-file call-with-input-file) | |
73 | (define my-open-output-file open-output-file) | |
74 | ||
75 | ; ========================================================================== | |
76 | ; do-ec | |
77 | ; ========================================================================== | |
78 | ||
79 | (my-check | |
80 | (let ((x 0)) (do-ec (set! x (+ x 1))) x) | |
81 | => 1) | |
82 | ||
83 | (my-check | |
84 | (let ((x 0)) (do-ec (:range i 10) (set! x (+ x 1))) x) | |
85 | => 10) | |
86 | ||
87 | (my-check | |
88 | (let ((x 0)) (do-ec (:range n 10) (:range k n) (set! x (+ x 1))) x) | |
89 | => 45) | |
90 | ||
91 | ||
92 | ; ========================================================================== | |
93 | ; list-ec and basic qualifiers | |
94 | ; ========================================================================== | |
95 | ||
96 | (my-check (list-ec 1) => '(1)) | |
97 | ||
98 | (my-check (list-ec (:range i 4) i) => '(0 1 2 3)) | |
99 | ||
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)) ) | |
102 | ||
103 | (my-check | |
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)) ) | |
106 | ||
107 | (my-check | |
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)) ) | |
110 | ||
111 | (my-check | |
112 | (list-ec (:range n 5) | |
113 | (and (even? n) (> n 2)) | |
114 | (:range k (+ n 1)) | |
115 | (list n k) ) | |
116 | => '((4 0) (4 1) (4 2) (4 3) (4 4)) ) | |
117 | ||
118 | (my-check | |
119 | (list-ec (:range n 5) | |
120 | (or (even? n) (> n 3)) | |
121 | (:range k (+ n 1)) | |
122 | (list n k) ) | |
123 | => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) ) | |
124 | ||
125 | (my-check | |
126 | (let ((x 0)) (list-ec (:range n 10) (begin (set! x (+ x 1))) n) x) | |
127 | => 10 ) | |
128 | ||
129 | (my-check | |
130 | (list-ec (nested (:range n 3) (:range k n)) k) | |
131 | => '(0 0 1) ) | |
132 | ||
133 | ||
134 | ; ========================================================================== | |
135 | ; Other comprehensions | |
136 | ; ========================================================================== | |
137 | ||
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)) | |
142 | ||
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") | |
147 | ||
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") | |
152 | ||
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)) | |
157 | ||
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)) | |
162 | ||
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) | |
168 | ||
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) | |
175 | ||
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) | |
179 | ||
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) | |
183 | ||
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) | |
188 | ||
189 | (my-check | |
190 | (let ((last-i -1)) | |
191 | (first-ec #f (:range i 10) (begin (set! last-i i)) i) | |
192 | last-i ) | |
193 | => 0 ) | |
194 | ||
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) | |
199 | ||
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) | |
204 | ||
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) | |
210 | ||
211 | (my-check | |
212 | (let ((sum-sqr (lambda (x result) (+ result (* x x))))) | |
213 | (fold-ec 0 (:range i 10) i sum-sqr) ) | |
214 | => 285 ) | |
215 | ||
216 | (my-check | |
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) ) | |
220 | => 284 ) | |
221 | ||
222 | (my-check | |
223 | (fold3-ec 'infinity (:range i 0) i min min) | |
224 | => 'infinity ) | |
225 | ||
226 | ||
227 | ; ========================================================================== | |
228 | ; Typed generators | |
229 | ; ========================================================================== | |
230 | ||
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)) | |
236 | ||
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)) | |
242 | ||
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)) | |
247 | (my-check | |
248 | (list-ec (:vector x (vector 1) (vector 2) (vector 3)) x) | |
249 | => '(1 2 3)) | |
250 | ||
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)) | |
256 | ||
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) => '()) | |
261 | ||
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)) | |
266 | ||
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.)) | |
270 | ||
271 | (my-check | |
272 | (string-ec (:char-range c #\a #\z) c) | |
273 | => "abcdefghijklmnopqrstuvwxyz" ) | |
274 | ||
275 | (my-check | |
276 | (begin | |
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) ) | |
283 | ||
284 | (my-check | |
285 | (begin | |
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) ) | |
292 | ||
293 | ||
294 | ; ========================================================================== | |
295 | ; The special generators :do :let :parallel :while :until | |
296 | ; ========================================================================== | |
297 | ||
298 | (my-check (list-ec (:do ((i 0)) (< i 4) ((+ i 1))) i) => '(0 1 2 3)) | |
299 | ||
300 | (my-check | |
301 | (list-ec | |
302 | (:do (let ((x 'x))) | |
303 | ((i 0)) | |
304 | (< i 4) | |
305 | (let ((j (- 10 i)))) | |
306 | #t | |
307 | ((+ i 1)) ) | |
308 | j ) | |
309 | => '(10 9 8 7) ) | |
310 | ||
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)) | |
314 | ||
315 | (my-check | |
316 | (list-ec (:parallel (:range i 1 10) (:list x '(a b c))) (list i x)) | |
317 | => '((1 a) (2 b) (3 c)) ) | |
318 | ||
319 | (my-check | |
320 | (list-ec (:while (:range i 1 10) (< i 5)) i) | |
321 | => '(1 2 3 4) ) | |
322 | ||
323 | (my-check | |
324 | (list-ec (:until (:range i 1 10) (>= i 5)) i) | |
325 | => '(1 2 3 4 5) ) | |
326 | ||
327 | ; with generator that might use inner bindings | |
328 | ||
329 | (my-check | |
330 | (list-ec (:while (:list i '(1 2 3 4 5 6 7 8 9)) (< i 5)) i) | |
331 | => '(1 2 3 4) ) | |
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 | |
336 | ||
337 | (my-check | |
338 | (list-ec (:until (:list i '(1 2 3 4 5 6 7 8 9)) (>= i 5)) i) | |
339 | => '(1 2 3 4 5) ) | |
340 | ||
341 | (my-check | |
342 | (list-ec (:while (:vector x (index i) '#(1 2 3 4 5)) | |
343 | (< x 10)) | |
344 | x) | |
345 | => '(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 | |
348 | ; 4-Jun-2007. | |
349 | ||
350 | ; combine :while/:until and :parallel | |
351 | ||
352 | (my-check | |
353 | (list-ec (:while (:parallel (:range i 1 10) | |
354 | (:list j '(1 2 3 4 5 6 7 8 9))) | |
355 | (< i 5)) | |
356 | (list i j)) | |
357 | => '((1 1) (2 2) (3 3) (4 4))) | |
358 | ||
359 | (my-check | |
360 | (list-ec (:until (:parallel (:range i 1 10) | |
361 | (:list j '(1 2 3 4 5 6 7 8 9))) | |
362 | (>= i 5)) | |
363 | (list i j)) | |
364 | => '((1 1) (2 2) (3 3) (4 4) (5 5))) | |
365 | ||
366 | ; check that :while/:until really stop the generator | |
367 | ||
368 | (my-check | |
369 | (let ((n 0)) | |
370 | (do-ec (:while (:range i 1 10) (begin (set! n (+ n 1)) (< i 5))) | |
371 | (if #f #f)) | |
372 | n) | |
373 | => 5) | |
374 | ||
375 | (my-check | |
376 | (let ((n 0)) | |
377 | (do-ec (:until (:range i 1 10) (begin (set! n (+ n 1)) (>= i 5))) | |
378 | (if #f #f)) | |
379 | n) | |
380 | => 5) | |
381 | ||
382 | (my-check | |
383 | (let ((n 0)) | |
384 | (do-ec (:while (:parallel (:range i 1 10) | |
385 | (:do () (begin (set! n (+ n 1)) #t) ())) | |
386 | (< i 5)) | |
387 | (if #f #f)) | |
388 | n) | |
389 | => 5) | |
390 | ||
391 | (my-check | |
392 | (let ((n 0)) | |
393 | (do-ec (:until (:parallel (:range i 1 10) | |
394 | (:do () (begin (set! n (+ n 1)) #t) ())) | |
395 | (>= i 5)) | |
396 | (if #f #f)) | |
397 | n) | |
398 | => 5) | |
399 | ||
400 | ; ========================================================================== | |
401 | ; The dispatching generator | |
402 | ; ========================================================================== | |
403 | ||
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)) | |
406 | ||
407 | (my-check (list-ec (: c "ab") c) => '(#\a #\b)) | |
408 | (my-check (list-ec (: c "ab" "cd") c) => '(#\a #\b #\c #\d)) | |
409 | ||
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)) | |
412 | ||
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)) | |
419 | ||
420 | (my-check (list-ec (: i 0.0 1.0 0.2) i) => '(0. 0.2 0.4 0.6 0.8)) | |
421 | ||
422 | (my-check (list-ec (: c #\a #\c) c) => '(#\a #\b #\c)) | |
423 | ||
424 | (my-check | |
425 | (begin | |
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) ) | |
432 | ||
433 | (my-check | |
434 | (begin | |
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) ) | |
441 | ||
442 | ||
443 | ; ========================================================================== | |
444 | ; With index variable | |
445 | ; ========================================================================== | |
446 | ||
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))) | |
450 | ||
451 | (my-check | |
452 | (list-ec (:range i (index j) 0 -3 -1) (list i j)) | |
453 | => '((0 0) (-1 1) (-2 2)) ) | |
454 | ||
455 | (my-check | |
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)) ) | |
458 | ||
459 | (my-check | |
460 | (list-ec (:char-range c (index i) #\a #\c) (list c i)) | |
461 | => '((#\a 0) (#\b 1) (#\c 2)) ) | |
462 | ||
463 | (my-check | |
464 | (list-ec (: x (index i) '(a b c d)) (list x i)) | |
465 | => '((a 0) (b 1) (c 2) (d 3)) ) | |
466 | ||
467 | (my-check | |
468 | (begin | |
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)) ) | |
475 | ||
476 | ||
477 | ; ========================================================================== | |
478 | ; The examples from the SRFI document | |
479 | ; ========================================================================== | |
480 | ||
481 | ; from Abstract | |
482 | ||
483 | (my-check (list-ec (: i 5) (* i i)) => '(0 1 4 9 16)) | |
484 | ||
485 | (my-check | |
486 | (list-ec (: n 1 4) (: i n) (list n i)) | |
487 | => '((1 0) (2 0) (2 1) (3 0) (3 1) (3 2)) ) | |
488 | ||
489 | ; from Generators | |
490 | ||
491 | (my-check | |
492 | (list-ec (: x (index i) "abc") (list x i)) | |
493 | => '((#\a 0) (#\b 1) (#\c 2)) ) | |
494 | ||
495 | (my-check | |
496 | (list-ec (:string c (index i) "a" "b") (cons c i)) | |
497 | => '((#\a . 0) (#\b . 1)) ) | |
498 | ||
499 | ||
500 | ; ========================================================================== | |
501 | ; Little Shop of Horrors | |
502 | ; ========================================================================== | |
503 | ||
504 | (my-check (list-ec (:range x 5) (:range x x) x) => '(0 0 1 0 1 2 0 1 2 3)) | |
505 | ||
506 | (my-check (list-ec (:list x '(2 "23" (4))) (: y x) y) => '(0 1 #\2 #\3 4)) | |
507 | ||
508 | (my-check | |
509 | (list-ec (:parallel (:integers x) | |
510 | (:do ((i 10)) (< x i) ((- i 1)))) | |
511 | (list x i)) | |
512 | => '((0 10) (1 9) (2 8) (3 7) (4 6)) ) | |
513 | ||
514 | ||
515 | ; ========================================================================== | |
516 | ; Less artificial examples | |
517 | ; ========================================================================== | |
518 | ||
519 | (define (factorial n) ; n * (n-1) * .. * 1 for n >= 0 | |
520 | (product-ec (:range k 2 (+ n 1)) k) ) | |
521 | ||
522 | (my-check (factorial 0) => 1) | |
523 | (my-check (factorial 1) => 1) | |
524 | (my-check (factorial 3) => 6) | |
525 | (my-check (factorial 5) => 120) | |
526 | ||
527 | ||
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) )) | |
535 | ||
536 | (my-check | |
537 | (eratosthenes 50) | |
538 | => '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) ) | |
539 | ||
540 | (my-check | |
541 | (length (eratosthenes 100000)) | |
542 | => 9592 ) ; we expect 10^5/ln(10^5) | |
543 | ||
544 | ||
545 | (define (pythagoras n) ; a, b, c s.t. 1 <= a <= b <= c <= n, a^2 + b^2 = c^2 | |
546 | (list-ec | |
547 | (:let sqr-n (* n n)) | |
548 | (:range a 1 (+ n 1)) | |
549 | ; (begin (display a) (display " ")) | |
550 | (:let sqr-a (* a a)) | |
551 | (:range b a (+ n 1)) | |
552 | (:let sqr-c (+ sqr-a (* b b))) | |
553 | (if (<= sqr-c sqr-n)) | |
554 | (:range c b (+ n 1)) | |
555 | (if (= (* c c) sqr-c)) | |
556 | (list a b c) )) | |
557 | ||
558 | (my-check | |
559 | (pythagoras 15) | |
560 | => '((3 4 5) (5 12 13) (6 8 10) (9 12 15)) ) | |
561 | ||
562 | (my-check | |
563 | (length (pythagoras 200)) | |
564 | => 127 ) | |
565 | ||
566 | ||
567 | (define (qsort xs) ; stable | |
568 | (if (null? xs) | |
569 | '() | |
570 | (let ((pivot (car xs)) (xrest (cdr xs))) | |
571 | (append | |
572 | (qsort (list-ec (:list x xrest) (if (< x pivot)) x)) | |
573 | (list pivot) | |
574 | (qsort (list-ec (:list x xrest) (if (>= x pivot)) x)) )))) | |
575 | ||
576 | (my-check | |
577 | (qsort '(1 5 4 2 4 5 3 2 1 3)) | |
578 | => '(1 1 2 2 3 3 4 4 5 5) ) | |
579 | ||
580 | ||
581 | (define (pi-BBP m) ; approx. of pi within 16^-m (Bailey-Borwein-Plouffe) | |
582 | (sum-ec | |
583 | (:range n 0 (+ m 1)) | |
584 | (:let n8 (* 8 n)) | |
585 | (* (- (/ 4 (+ n8 1)) | |
586 | (+ (/ 2 (+ n8 4)) | |
587 | (/ 1 (+ n8 5)) | |
588 | (/ 1 (+ n8 6)))) | |
589 | (/ 1 (expt 16 n)) ))) | |
590 | ||
591 | (my-check | |
592 | (pi-BBP 5) | |
593 | => (/ 40413742330349316707 12864093722915635200) ) | |
594 | ||
595 | ||
596 | (define (read-line port) ; next line (incl. #\newline) of port | |
597 | (let ((line | |
598 | (string-ec | |
599 | (:until (:port c port read-char) | |
600 | (char=? c #\newline) ) | |
601 | c ))) | |
602 | (if (string=? line "") | |
603 | (read-char port) ; eof-object | |
604 | line ))) | |
605 | ||
606 | (define (read-lines filename) ; list of all lines | |
607 | (my-call-with-input-file | |
608 | filename | |
609 | (lambda (port) | |
610 | (list-ec (:port line port read-line) line) ))) | |
611 | ||
612 | (my-check | |
613 | (begin | |
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)) ) | |
b4699977 LC |
619 | |
620 | (false-if-exception (delete-file "tmp1")) |