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