1;; Adapted for R7RS from original SRFI 41 r5rs.ss.
2
3;; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri,
4;; USA.  All rights reserved.  Permission is hereby granted, free of
5;; charge, to any person obtaining a copy of this software and
6;; associated documentation files (the "Software"), to deal in the
7;; Software without restriction, including without limitation the
8;; rights to use, copy, modify, merge, publish, distribute,
9;; sublicense, and/or sell copies of the Software, and to permit
10;; persons to whom the Software is furnished to do so, subject to the
11;; following conditions: The above copyright notice and this
12;; permission notice shall be included in all copies or substantial
13;; portions of the Software.  THE SOFTWARE IS PROVIDED "AS IS",
14;; WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
15;; LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
16;; PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
17;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
18;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
19;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
20;; OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21
22;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; unit tests
23
24(define-library (srfi 41 test)
25  (import (scheme base) (srfi 41) (chibi test))
26  (export run-tests)
27  (begin
28
29    (define (add1 n) (+ n 1))
30    (define strm123 (stream 1 2 3))
31    (define (lsec proc . args)
32      (lambda x (apply proc (append args x))))
33    (define (rsec proc . args)
34      (lambda x (apply proc (reverse (append (reverse args) (reverse x))))))
35    (define nats
36      (stream-cons 0 (stream-map add1 nats)))
37
38    ;; executing (run-tests) should produce no output
39    (define (run-tests)
40
41      (test-begin "srfi-41: streams")
42
43      ;; stream-null
44      (test #t (stream? stream-null))
45      (test #t (stream-null? stream-null))
46      (test #f (stream-pair? stream-null))
47
48      ;; stream-cons
49      (test #t (stream? (stream-cons 1 stream-null)))
50      (test #f (stream-null? (stream-cons 1 stream-null)))
51      (test #t (stream-pair? (stream-cons 1 stream-null)))
52
53      ;; stream?
54      (test #t (stream? stream-null))
55      (test #t (stream? (stream-cons 1 stream-null)))
56      (test #f (stream? "four"))
57
58      ;; stream-null?
59      (test #t (stream-null? stream-null))
60      (test #f (stream-null? (stream-cons 1 stream-null)))
61      (test #f (stream-null? "four"))
62
63      ;; stream-pair?
64      (test #f (stream-pair? stream-null))
65      (test #t (stream-pair? (stream-cons 1 stream-null)))
66      (test #f (stream-pair? "four"))
67
68      ;; stream-car
69      (test-error (stream-car "four")) ; "stream-car: non-stream"
70      (test-error (stream-car stream-null)) ; "stream-car: null stream"
71      (test 1 (stream-car strm123))
72
73      ;; stream-cdr
74      (test-error (stream-cdr "four")) ; "stream-cdr: non-stream"
75      (test-error (stream-cdr stream-null)) ; "stream-cdr: null stream"
76      (test 2 (stream-car (stream-cdr strm123)))
77
78      ;; stream-lambda
79      (test
80          '(2 4 6)
81          (stream->list
82           (letrec ((double
83                     (stream-lambda (strm)
84                                    (if (stream-null? strm)
85                                        stream-null
86                                        (stream-cons
87                                         (* 2 (stream-car strm))
88                                         (double (stream-cdr strm)))))))
89             (double strm123))))
90
91      ;; define-stream
92      (test
93          '(2 4 6)
94          (stream->list
95           (let ()
96             (define-stream (double strm)
97               (if (stream-null? strm)
98                   stream-null
99                   (stream-cons
100                    (* 2 (stream-car strm))
101                    (double (stream-cdr strm)))))
102             (double strm123))))
103
104      ;; list->stream
105      (test-error (list->stream "four")) ; "list->stream: non-list argument"
106      (test '() (stream->list (list->stream '())))
107      (test '(1 2 3) (stream->list (list->stream '(1 2 3))))
108
109      ;; port->stream
110      (let* ((p (open-input-string "; Copyright 2007"))
111             (s (port->stream p)))
112        (test-error (port->stream "four"))
113        (test "; Copyright" (list->string (stream->list 11 s)) )
114        (close-input-port p))
115
116      ;; stream
117      (test '() (stream->list (stream)))
118      (test '(1) (stream->list (stream 1)))
119      (test '(1 2 3) (stream->list (stream 1 2 3)))
120
121      ;; stream->list
122      (test-error (stream->list '())) ; "stream->list: non-stream argument"
123      (test-error (stream->list "four" strm123)) ; "stream->list: non-integer count"
124      (test-error (stream->list -1 strm123)) ; "stream->list: negative count"
125      (test '() (stream->list (stream)))
126      (test '(1 2 3) (stream->list strm123))
127      (test '(1 2 3) (stream->list 5 strm123))
128      (test '(1 2 3) (stream->list 3 (stream-from 1)))
129
130      ;; stream-append
131      (test-error (stream-append "four")) ; "stream-append: non-stream argument"
132      (test '(1 2 3) (stream->list (stream-append strm123)))
133      (test '(1 2 3 1 2 3) (stream->list (stream-append strm123 strm123)))
134      (test '(1 2 3 1 2 3 1 2 3)
135          (stream->list (stream-append strm123 strm123 strm123)))
136      (test '(1 2 3) (stream->list (stream-append strm123 stream-null)))
137      (test '(1 2 3) (stream->list (stream-append stream-null strm123)))
138
139      ;; stream-concat
140      (test-error (stream-concat "four")) ; "stream-concat: non-stream argument"
141      (test '(1 2 3) (stream->list (stream-concat (stream strm123))))
142      (test '(1 2 3 1 2 3)
143          (stream->list (stream-concat (stream strm123 strm123))))
144
145      ;; stream-constant
146      (test 1 (stream-ref (stream-constant 1) 100))
147      (test 1 (stream-ref (stream-constant 1 2) 100))
148      (test 1 (stream-ref (stream-constant 1 2 3) 3))
149
150      ;; stream-drop
151      (test-error (stream-drop "four" strm123)) ; "stream-drop: non-integer argument"
152      (test-error (stream-drop -1 strm123)) ; "stream-drop: negative argument"
153      (test-error (stream-drop 2 "four")) ; "stream-drop: non-stream argument"
154      (test '() (stream->list (stream-drop 0 stream-null)))
155      (test '(1 2 3) (stream->list (stream-drop 0 strm123)))
156      (test '(2 3) (stream->list (stream-drop 1 strm123)))
157      (test '() (stream->list (stream-drop 5 strm123)))
158
159      ;; stream-drop-while
160      (test-error ; "stream-drop-while: non-procedural argument"
161       (stream-drop-while "four" strm123))
162      (test-error ; "stream-drop-while: non-stream argument"
163       (stream-drop-while odd? "four"))
164      (test '() (stream->list (stream-drop-while odd? stream-null)))
165      (test '(2 3) (stream->list (stream-drop-while odd? strm123)))
166      (test '(1 2 3) (stream->list (stream-drop-while even? strm123)))
167      (test '() (stream->list (stream-drop-while positive? strm123)))
168      (test '(1 2 3) (stream->list (stream-drop-while negative? strm123)))
169
170      ;; stream-filter
171      (test-error ; "stream-filter: non-procedural argument"
172       (stream-filter "four" strm123))
173      (test-error (stream-filter odd? '())) ; "stream-filter: non-stream argument"
174      (test #t (stream-null? (stream-filter odd? (stream))))
175      (test '(1 3) (stream->list (stream-filter odd? strm123)))
176      (test '(2) (stream->list (stream-filter even? strm123)))
177      (test '(1 2 3) (stream->list (stream-filter positive? strm123)))
178      (test '() (stream->list (stream-filter negative? strm123)))
179      (let loop ((n 10))
180        (test #t (odd? (stream-ref (stream-filter odd? (stream-from 0)) n)))
181        (if (positive? n) (loop (- n 1))))
182      (let loop ((n 10))
183        (test #f (even? (stream-ref (stream-filter odd? (stream-from 0)) n)))
184        (if (positive? n) (loop (- n 1))))
185
186      ;; stream-fold
187      (test-error ; "stream-fold: non-procedural argument"
188       (stream-fold "four" 0 strm123))
189      (test-error (stream-fold + 0 '())) ; "stream-fold: non-stream argument"
190      (test 6 (stream-fold + 0 strm123))
191
192      ;; stream-for-each
193      (test-error ; "stream-for-each: non-procedural argument"
194       (stream-for-each "four" strm123))
195      (test-error ; "stream-for-each: no stream arguments"
196       (stream-for-each +))
197      (test-error ; "stream-for-each: non-stream argument"
198       (stream-for-each + "four"))
199      (test 6
200          (let ((sum 0))
201            (stream-for-each (lambda (x) (set! sum (+ sum x))) strm123)
202            sum))
203
204      ;; stream-from
205      (test-error (stream-from "four")) ; "stream-from: non-numeric starting number"
206      (test-error (stream-from 1 "four")) ; "stream-from: non-numeric step size"
207      (test 100 (stream-ref (stream-from 0) 100))
208      (test 201 (stream-ref (stream-from 1 2) 100))
209      (test -100 (stream-ref (stream-from 0 -1) 100))
210
211      ;; stream-iterate
212      (test-error (stream-iterate "four" 0)) ; "stream-iterate: non-procedural argument"
213      (test '(1 2 3) (stream->list 3 (stream-iterate (lsec + 1) 1)))
214
215      ;; stream-length
216      (test-error (stream-length "four")) ; "stream-length: non-stream argument"
217      (test 0 (stream-length (stream)))
218      (test 3 (stream-length strm123))
219
220      ;; stream-let
221      (test '(2 4 6)
222          (stream->list
223           (stream-let loop ((strm strm123))
224                       (if (stream-null? strm)
225                           stream-null
226                           (stream-cons
227                            (* 2 (stream-car strm))
228                            (loop (stream-cdr strm)))))))
229
230      ;; stream-map
231      (test-error (stream-map "four" strm123)) ; "stream-map: non-procedural argument"
232      (test-error (stream-map odd?)) ; "stream-map: no stream arguments"
233      (test-error (stream-map odd? "four")) ; "stream-map: non-stream argument"
234      (test '(-1 -2 -3) (stream->list (stream-map - strm123)))
235      (test '(2 4 6) (stream->list (stream-map + strm123 strm123)))
236      (test '(2 4 6) (stream->list (stream-map + strm123 (stream-from 1))))
237      (test '(2 4 6) (stream->list (stream-map + (stream-from 1) strm123)))
238      (test '(3 6 9) (stream->list (stream-map + strm123 strm123 strm123)))
239
240      ;; stream-match
241      (test-error (stream-match '(1 2 3) (_ 'ok))) ; "stream-match: non-stream argument"
242      (test-error (stream-match strm123 (() 42))) ; "stream-match: pattern failure"
243      (test 'ok (stream-match stream-null (() 'ok)))
244      (test 'ok (stream-match strm123 (() 'no) (else 'ok)))
245      (test 1 (stream-match (stream 1) (() 'no) ((a) a)))
246      (test 'ok (stream-match (stream 1) (() 'no) ((_) 'ok)))
247      (test '(1 2 3) (stream-match strm123 ((a b c) (list a b c))))
248      (test 1 (stream-match strm123 ((a . _) a)))
249      (test '(1 2) (stream-match strm123 ((a b . _) (list a b))))
250      (test '(1 2 3)
251          (stream-match strm123 ((a b . c) (list a b (stream-car c)))))
252      (test '(1 2 3) (stream-match strm123 (s (stream->list s))))
253      (test 'ok (stream-match strm123 ((a . _) (= a 1) 'ok)))
254      (test 'no (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)))
255      (test 'no (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)))
256      (test 'yes (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no)))
257
258      ;; stream-of
259      (test '(7 15 31)
260          (stream->list
261           (stream-of (+ y 6)
262                      (x in (stream-range 1 6))
263                      (odd? x)
264                      (y is (* x x)))))
265      (test '(1 2 3 4 2 4 6 8 3 6 9 12)
266          (stream->list
267           (stream-of (* x y)
268                      (x in (stream-range 1 4))
269                      (y in (stream-range 1 5)))))
270      (test 1 (stream-car (stream-of 1)))
271
272      ;; stream-range
273      (test-error (stream-range "four" 0)) ; "stream-range: non-numeric starting number"
274      (test-error (stream-range 0 "four")) ; "stream-range: non-numeric ending number"
275      (test-error (stream-range 1 2 "three")) ; "stream-range: non-numeric step size"
276      (test '(0 1 2 3 4) (stream->list (stream-range 0 5)))
277      (test '(5 4 3 2 1) (stream->list (stream-range 5 0)))
278      (test '(0 2 4) (stream->list (stream-range 0 5 2)))
279      (test '(5 3 1) (stream->list (stream-range 5 0 -2)))
280      (test '() (stream->list (stream-range 0 1 -1)))
281
282      ;; stream-ref
283      (test-error (stream-ref '() 4)) ; "stream-ref: non-stream argument"
284      (test-error (stream-ref nats 3.5)) ; "stream-ref: non-integer argument"
285      (test-error (stream-ref nats -3)) ; "stream-ref: negative argument"
286      (test-error (stream-ref strm123 5)) ; "stream-ref: beyond end of stream"
287      (test 1 (stream-ref strm123 0))
288      (test 2 (stream-ref strm123 1))
289      (test 3 (stream-ref strm123 2))
290
291      ;; stream-reverse
292      (test-error (stream-reverse '())) ; "stream-reverse: non-stream argument"
293      (test '() (stream->list (stream-reverse (stream))))
294      (test '(3 2 1) (stream->list (stream-reverse strm123)))
295
296      ;; stream-scan
297      (test-error ; "stream-scan: non-procedural argument"
298       (stream-scan "four" 0 strm123))
299      (test-error (stream-scan + 0 '())) ; "stream-scan: non-stream argument"
300      (test '(0 1 3 6) (stream->list (stream-scan + 0 strm123)))
301
302      ;; stream-take
303      (test-error (stream-take 5 "four")) ; "stream-take: non-stream argument"
304      (test-error (stream-take "four" strm123)) ; "stream-take: non-integer argument"
305      (test-error (stream-take -4 strm123)) ; "stream-take: negative argument"
306      (test '() (stream->list (stream-take 5 stream-null)))
307      (test '() (stream->list (stream-take 0 stream-null)))
308      (test '() (stream->list (stream-take 0 strm123)))
309      (test '(1 2) (stream->list (stream-take 2 strm123)))
310      (test '(1 2 3) (stream->list (stream-take 3 strm123)))
311      (test '(1 2 3) (stream->list (stream-take 5 strm123)))
312
313      ;; stream-take-while
314      (test-error ; "stream-take-while: non-stream argument"
315       (stream-take-while odd? "four"))
316      (test-error ; "stream-take-while: non-procedural argument"
317       (stream-take-while "four" strm123))
318      (test '(1) (stream->list (stream-take-while odd? strm123)))
319      (test '() (stream->list (stream-take-while even? strm123)))
320      (test '(1 2 3) (stream->list (stream-take-while positive? strm123)))
321      (test '() (stream->list (stream-take-while negative? strm123)))
322
323      ;; stream-unfold
324      (test-error ; "stream-unfold: non-procedural mapper"
325       (stream-unfold "four" odd? + 0))
326      (test-error ; "stream-unfold: non-procedural pred?"
327       (stream-unfold + "four" + 0))
328      (test-error ; "stream-unfold: non-procedural generator"
329       (stream-unfold + odd? "four" 0))
330      (test '(0 1 4 9 16 25 36 49 64 81)
331          (stream->list (stream-unfold (rsec expt 2) (rsec < 10) (rsec + 1) 0)))
332
333      ;; stream-unfolds
334      (test
335          '(0 1 2 3 4)
336          (stream->list
337           (stream-unfolds
338            (lambda (x)
339              (let ((n (car x)) (s (cdr x)))
340                (if (zero? n)
341                    (values 'dummy '())
342                    (values
343                     (cons (- n 1) (stream-cdr s))
344                     (list (stream-car s))))))
345            (cons 5 (stream-from 0)))))
346
347      ;; stream-zip
348      (test-error (stream-zip)) ; "stream-zip: no stream arguments"
349      (test-error (stream-zip "four")) ; "stream-zip: non-stream argument"
350      (test-error (stream-zip strm123 "four")) ; "stream-zip: non-stream argument"
351      (test '() (stream->list (stream-zip strm123 stream-null)))
352      (test '((1) (2) (3)) (stream->list (stream-zip strm123)))
353      (test '((1 1) (2 2) (3 3)) (stream->list (stream-zip strm123 strm123)))
354      (test '((1 1) (2 2) (3 3))
355          (stream->list (stream-zip strm123 (stream-from 1))))
356      (test '((1 1 1) (2 2 2) (3 3 3))
357          (stream->list (stream-zip strm123 strm123 strm123)))
358
359      (test-end))))
360