Lines Matching refs:stream
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)
30 (define-syntax define-stream
32 ((define-stream (name . formal) body0 body1 ...)
33 (define name (stream-lambda formal body0 body1 ...)))))
35 (define (list->stream objs)
36 (define list->stream
37 (stream-lambda (objs)
39 stream-null
40 (stream-cons (car objs) (list->stream (cdr objs))))))
42 (error 'list->stream "non-list argument")
43 (list->stream objs)))
45 (define (port->stream . port)
46 (define port->stream
47 (stream-lambda (p)
50 stream-null
51 (stream-cons c (port->stream p))))))
54 (error 'port->stream "non-input-port argument")
55 (port->stream p))))
57 (define-syntax stream function
59 ((stream) stream-null)
60 ((stream x y ...) (stream-cons x (stream y ...)))))
62 (define (stream->list . 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"))
69 (if (or (zero? n) (stream-null? strm))
71 (cons (stream-car strm) (loop (- n 1) (stream-cdr strm)))))))))
73 (define (stream-append . strms)
74 (define stream-append
75 (stream-lambda (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))))
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)))
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)))))))
107 (define (stream-drop n strm)
108 (define stream-drop
109 (stream-lambda (n strm)
110 (if (or (zero? n) (stream-null? 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))))
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))
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))))
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))))
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"))
143 (if (stream-null? strm)
145 (loop (proc base (stream-car strm)) (stream-cdr strm)))))))
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))))
158 (define (stream-from first . step)
159 (define stream-from
160 (stream-lambda (first delta)
161 (stream-cons first (stream-from (+ first delta) delta))))
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)))))
167 (define (stream-iterate proc base)
168 (define stream-iterate
169 (stream-lambda (base)
170 (stream-cons base (stream-iterate (proc base)))))
172 (error 'stream-iterate "non-procedural argument")
173 (stream-iterate base)))
175 (define (stream-length strm)
176 (if (not (stream? strm))
177 (error 'stream-length "non-stream argument")
179 (if (stream-null? strm)
181 (loop (+ len 1) (stream-cdr strm))))))
183 (define-syntax stream-let
185 ((stream-let tag ((name val) ...) body1 body2 ...)
186 ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))))
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))))
201 (define-syntax stream-match
203 ((stream-match strm-expr clause ...)
206 ((not (stream? strm)) (error 'stream-match "non-stream argument"))
207 ((stream-match-test strm clause) => car) ...
208 (else (error 'stream-match "pattern failure")))))))
210 (define-syntax stream-match-test
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)))))
217 (define-syntax stream-match-pattern
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)
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)
237 ((stream-match-pattern strm var (binding ...) body)
240 (define-syntax stream-of
243 (stream-of-aux expr stream-null rest ...))))
245 (define-syntax stream-of-aux
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)
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))))
260 (define (stream-range first past . step)
261 (define stream-range
262 (stream-lambda (first past delta lt?)
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"))
270 (error 'stream-range "non-numeric step size")
272 (stream-range first past delta lt?)))))))
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"))
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))))))))
283 (define (stream-reverse strm)
284 (define stream-reverse
285 (stream-lambda (strm rev)
286 (if (stream-null? strm)
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)))
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))))
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))))
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))))
325 (define (stream-unfold mapper pred? generator base)
326 (define stream-unfold
327 (stream-lambda (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))))
336 (define (stream-unfolds gen seed)
341 (define unfold-result-stream
342 (stream-lambda (gen seed)
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))))
351 (stream-cons
353 (result-stream->output-stream (stream-cdr result-stream) i)))
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)
362 (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
364 (error 'stream-unfolds "non-procedural argument")
365 (result-stream->output-streams (unfold-result-stream gen seed))))
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))))