Commit | Line | Data |
---|---|---|
50d08cd8 CJY |
1 | ;;; srfi-41.scm -- SRFI 41 streams |
2 | ||
3 | ;; Copyright (c) 2007 Philip L. Bewig | |
4 | ;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc. | |
5 | ||
6 | ;; Permission is hereby granted, free of charge, to any person obtaining | |
7 | ;; a copy of this software and associated documentation files (the | |
8 | ;; "Software"), to deal in the Software without restriction, including | |
9 | ;; without limitation the rights to use, copy, modify, merge, publish, | |
10 | ;; distribute, sublicense, and/or sell copies of the Software, and to | |
11 | ;; permit persons to whom the Software is furnished to do so, subject to | |
12 | ;; the following conditions: | |
13 | ;; | |
14 | ;; The above copyright notice and this permission notice shall be | |
15 | ;; included in all copies or substantial portions of the Software. | |
16 | ;; | |
17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
18 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES | |
19 | ;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND | |
20 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS | |
21 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN | |
22 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN | |
23 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | |
24 | ;; SOFTWARE. | |
25 | ||
26 | (define-module (srfi srfi-41) | |
27 | #:use-module (srfi srfi-1) | |
28 | #:use-module (srfi srfi-8) | |
29 | #:use-module (srfi srfi-9) | |
b6e374e5 | 30 | #:use-module (srfi srfi-9 gnu) |
50d08cd8 CJY |
31 | #:use-module (srfi srfi-26) |
32 | #:use-module (ice-9 match) | |
33 | #:export (stream-null stream-cons stream? stream-null? stream-pair? | |
34 | stream-car stream-cdr stream-lambda define-stream | |
35 | list->stream port->stream stream stream->list stream-append | |
36 | stream-concat stream-constant stream-drop stream-drop-while | |
37 | stream-filter stream-fold stream-for-each stream-from | |
38 | stream-iterate stream-length stream-let stream-map | |
39 | stream-match stream-of stream-range stream-ref stream-reverse | |
40 | stream-scan stream-take stream-take-while stream-unfold | |
41 | stream-unfolds stream-zip)) | |
42 | ||
43 | (cond-expand-provide (current-module) '(srfi-41)) | |
44 | ||
45 | ;;; Private supporting functions and macros. | |
46 | ||
47 | (define-syntax-rule (must pred obj func msg args ...) | |
48 | (let ((item obj)) | |
49 | (unless (pred item) | |
50 | (throw 'wrong-type-arg func msg (list args ...) (list item))))) | |
51 | ||
52 | (define-syntax-rule (must-not pred obj func msg args ...) | |
53 | (let ((item obj)) | |
54 | (when (pred item) | |
55 | (throw 'wrong-type-arg func msg (list args ...) (list item))))) | |
56 | ||
57 | (define-syntax-rule (must-every pred objs func msg args ...) | |
58 | (let ((flunk (remove pred objs))) | |
59 | (unless (null? flunk) | |
60 | (throw 'wrong-type-arg func msg (list args ...) flunk)))) | |
61 | ||
62 | (define-syntax-rule (first-value expr) | |
63 | (receive (first . _) expr | |
64 | first)) | |
65 | ||
66 | (define-syntax-rule (second-value expr) | |
67 | (receive (first second . _) expr | |
68 | second)) | |
69 | ||
70 | (define-syntax-rule (third-value expr) | |
71 | (receive (first second third . _) expr | |
72 | third)) | |
73 | ||
74 | (define-syntax define-syntax* | |
75 | (syntax-rules () | |
76 | ((_ (name . args) body ...) | |
77 | (define-syntax name (lambda* args body ...))) | |
78 | ((_ name syntax) | |
79 | (define-syntax name syntax)))) | |
80 | ||
81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
82 | ;; | |
83 | ;; Here we include a copy of the code of srfi-45.scm (but with renamed | |
84 | ;; identifiers), in order to create a new promise type that's disjoint | |
85 | ;; from the promises created by srfi-45. Ideally this should be done | |
86 | ;; using a 'make-promise-type' macro that instantiates a copy of this | |
87 | ;; code, but a psyntax bug in Guile 2.0 prevents this from working | |
88 | ;; properly: <http://bugs.gnu.org/13995>. So for now, we duplicate the | |
89 | ;; code. | |
90 | ||
91 | ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. | |
92 | ;; Copyright (C) 2003 André van Tonder. All Rights Reserved. | |
93 | ||
94 | ;; Permission is hereby granted, free of charge, to any person | |
95 | ;; obtaining a copy of this software and associated documentation | |
96 | ;; files (the "Software"), to deal in the Software without | |
97 | ;; restriction, including without limitation the rights to use, copy, | |
98 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies | |
99 | ;; of the Software, and to permit persons to whom the Software is | |
100 | ;; furnished to do so, subject to the following conditions: | |
101 | ||
102 | ;; The above copyright notice and this permission notice shall be | |
103 | ;; included in all copies or substantial portions of the Software. | |
104 | ||
105 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
106 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
107 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND | |
108 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS | |
109 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN | |
110 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN | |
111 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | |
112 | ;; SOFTWARE. | |
113 | ||
114 | (define-record-type stream-promise (make-stream-promise val) stream-promise? | |
115 | (val stream-promise-val stream-promise-val-set!)) | |
116 | ||
117 | (define-record-type stream-value (make-stream-value tag proc) stream-value? | |
118 | (tag stream-value-tag stream-value-tag-set!) | |
119 | (proc stream-value-proc stream-value-proc-set!)) | |
120 | ||
121 | (define-syntax-rule (stream-lazy exp) | |
122 | (make-stream-promise (make-stream-value 'lazy (lambda () exp)))) | |
123 | ||
124 | (define (stream-eager x) | |
125 | (make-stream-promise (make-stream-value 'eager x))) | |
126 | ||
127 | (define-syntax-rule (stream-delay exp) | |
128 | (stream-lazy (stream-eager exp))) | |
129 | ||
130 | (define (stream-force promise) | |
131 | (let ((content (stream-promise-val promise))) | |
132 | (case (stream-value-tag content) | |
133 | ((eager) (stream-value-proc content)) | |
134 | ((lazy) (let* ((promise* ((stream-value-proc content))) | |
135 | (content (stream-promise-val promise))) | |
136 | (if (not (eqv? (stream-value-tag content) 'eager)) | |
137 | (begin (stream-value-tag-set! content | |
138 | (stream-value-tag (stream-promise-val promise*))) | |
139 | (stream-value-proc-set! content | |
140 | (stream-value-proc (stream-promise-val promise*))) | |
141 | (stream-promise-val-set! promise* content))) | |
142 | (stream-force promise)))))) | |
143 | ||
144 | ;; | |
145 | ;; End of the copy of the code from srfi-45.scm | |
146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
147 | ||
148 | ;;; Primitive stream functions and macros: (streams primitive) | |
149 | ||
150 | (define stream? stream-promise?) | |
151 | ||
3f1362ad | 152 | (define %stream-null (cons 'stream 'null)) |
50d08cd8 CJY |
153 | (define stream-null (stream-eager %stream-null)) |
154 | ||
155 | (define (stream-null? obj) | |
156 | (and (stream-promise? obj) | |
157 | (eqv? (stream-force obj) %stream-null))) | |
158 | ||
159 | (define-record-type stream-pare (make-stream-pare kar kdr) stream-pare? | |
160 | (kar stream-kar) | |
161 | (kdr stream-kdr)) | |
162 | ||
163 | (define (stream-pair? obj) | |
164 | (and (stream-promise? obj) (stream-pare? (stream-force obj)))) | |
165 | ||
166 | (define-syntax-rule (stream-cons obj strm) | |
167 | (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm)))) | |
168 | ||
169 | (define (stream-car strm) | |
170 | (must stream? strm 'stream-car "non-stream") | |
171 | (let ((pare (stream-force strm))) | |
172 | (must stream-pare? pare 'stream-car "null stream") | |
173 | (stream-force (stream-kar pare)))) | |
174 | ||
175 | (define (stream-cdr strm) | |
176 | (must stream? strm 'stream-cdr "non-stream") | |
177 | (let ((pare (stream-force strm))) | |
178 | (must stream-pare? pare 'stream-cdr "null stream") | |
179 | (stream-kdr pare))) | |
180 | ||
181 | (define-syntax-rule (stream-lambda formals body0 body1 ...) | |
182 | (lambda formals (stream-lazy (begin body0 body1 ...)))) | |
183 | ||
b6e374e5 CJY |
184 | (define* (stream-promise-visit promise #:key on-eager on-lazy) |
185 | (define content (stream-promise-val promise)) | |
186 | (case (stream-value-tag content) | |
187 | ((eager) (on-eager (stream-value-proc content))) | |
188 | ((lazy) (on-lazy (stream-value-proc content))))) | |
189 | ||
190 | (set-record-type-printer! stream-promise | |
191 | (lambda (strm port) | |
192 | (display "#<stream" port) | |
193 | (let loop ((strm strm)) | |
194 | (stream-promise-visit strm | |
195 | #:on-eager (lambda (pare) | |
196 | (cond ((eq? pare %stream-null) | |
197 | (write-char #\> port)) | |
198 | (else | |
199 | (write-char #\space port) | |
200 | (stream-promise-visit (stream-kar pare) | |
201 | #:on-eager (cut write <> port) | |
202 | #:on-lazy (lambda (_) (write-char #\? port))) | |
203 | (loop (stream-kdr pare))))) | |
204 | #:on-lazy (lambda (_) (display " ...>" port)))))) | |
205 | ||
50d08cd8 CJY |
206 | ;;; Derived stream functions and macros: (streams derived) |
207 | ||
208 | (define-syntax-rule (define-stream (name . formal) body0 body1 ...) | |
209 | (define name (stream-lambda formal body0 body1 ...))) | |
210 | ||
211 | (define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...) | |
212 | ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...)) | |
213 | ||
214 | (define (list->stream objs) | |
215 | (define (list? x) | |
216 | (or (proper-list? x) (circular-list? x))) | |
217 | (must list? objs 'list->stream "non-list argument") | |
218 | (stream-let recur ((objs objs)) | |
219 | (if (null? objs) stream-null | |
220 | (stream-cons (car objs) (recur (cdr objs)))))) | |
221 | ||
222 | (define* (port->stream #:optional (port (current-input-port))) | |
223 | (must input-port? port 'port->stream "non-input-port argument") | |
224 | (stream-let recur () | |
225 | (let ((c (read-char port))) | |
226 | (if (eof-object? c) stream-null | |
227 | (stream-cons c (recur)))))) | |
228 | ||
229 | (define-syntax stream | |
230 | (syntax-rules () | |
231 | ((_) stream-null) | |
232 | ((_ x y ...) (stream-cons x (stream y ...))))) | |
233 | ||
234 | ;; Common helper for the various eager-folding functions, such as | |
235 | ;; stream-fold, stream-drop, stream->list, stream-length, etc. | |
236 | (define-inlinable (stream-fold-aux proc base strm limit) | |
237 | (do ((val base (and proc (proc val (stream-car strm)))) | |
238 | (strm strm (stream-cdr strm)) | |
239 | (limit limit (and limit (1- limit)))) | |
240 | ((or (and limit (zero? limit)) (stream-null? strm)) | |
241 | (values val strm limit)))) | |
242 | ||
243 | (define stream->list | |
244 | (case-lambda | |
245 | ((strm) (stream->list #f strm)) | |
246 | ((n strm) | |
247 | (must stream? strm 'stream->list "non-stream argument") | |
248 | (when n | |
249 | (must integer? n 'stream->list "non-integer count") | |
250 | (must exact? n 'stream->list "inexact count") | |
251 | (must-not negative? n 'stream->list "negative count")) | |
252 | (reverse! (first-value (stream-fold-aux xcons '() strm n)))))) | |
253 | ||
254 | (define (stream-append . strms) | |
255 | (must-every stream? strms 'stream-append "non-stream argument") | |
256 | (stream-let recur ((strms strms)) | |
257 | (if (null? strms) stream-null | |
258 | (let ((strm (car strms))) | |
259 | (if (stream-null? strm) (recur (cdr strms)) | |
260 | (stream-cons (stream-car strm) | |
261 | (recur (cons (stream-cdr strm) (cdr strms))))))))) | |
262 | ||
263 | (define (stream-concat strms) | |
264 | (must stream? strms 'stream-concat "non-stream argument") | |
265 | (stream-let recur ((strms strms)) | |
266 | (if (stream-null? strms) stream-null | |
267 | (let ((strm (stream-car strms))) | |
268 | (must stream? strm 'stream-concat "non-stream object in input stream") | |
269 | (if (stream-null? strm) (recur (stream-cdr strms)) | |
270 | (stream-cons (stream-car strm) | |
271 | (recur (stream-cons (stream-cdr strm) | |
272 | (stream-cdr strms))))))))) | |
273 | ||
274 | (define stream-constant | |
275 | (case-lambda | |
276 | (() stream-null) | |
277 | (objs (list->stream (apply circular-list objs))))) | |
278 | ||
279 | (define-syntax* (stream-do x) | |
280 | (define (end x) | |
281 | (syntax-case x () | |
282 | (() #'(if #f #f)) | |
283 | ((result) #'result) | |
284 | ((result ...) #'(begin result ...)))) | |
285 | (define (var-step v s) | |
286 | (syntax-case s () | |
287 | (() v) | |
288 | ((e) #'e) | |
289 | (_ (syntax-violation 'stream-do "bad step expression" x s)))) | |
290 | ||
291 | (syntax-case x () | |
292 | ((_ ((var init . step) ...) | |
293 | (test result ...) | |
294 | expr ...) | |
295 | (with-syntax ((result (end #'(result ...))) | |
296 | ((step ...) (map var-step #'(var ...) #'(step ...)))) | |
297 | #'(stream-let loop ((var init) ...) | |
298 | (if test result | |
299 | (begin | |
300 | expr ... | |
301 | (loop step ...)))))))) | |
302 | ||
303 | (define (stream-drop n strm) | |
304 | (must integer? n 'stream-drop "non-integer argument") | |
305 | (must exact? n 'stream-drop "inexact argument") | |
306 | (must-not negative? n 'stream-drop "negative argument") | |
307 | (must stream? strm 'stream-drop "non-stream argument") | |
308 | (second-value (stream-fold-aux #f #f strm n))) | |
309 | ||
310 | (define (stream-drop-while pred? strm) | |
311 | (must procedure? pred? 'stream-drop-while "non-procedural argument") | |
312 | (must stream? strm 'stream-drop-while "non-stream argument") | |
313 | (stream-do ((strm strm (stream-cdr strm))) | |
314 | ((or (stream-null? strm) (not (pred? (stream-car strm)))) strm))) | |
315 | ||
316 | (define (stream-filter pred? strm) | |
317 | (must procedure? pred? 'stream-filter "non-procedural argument") | |
318 | (must stream? strm 'stream-filter "non-stream argument") | |
319 | (stream-let recur ((strm strm)) | |
320 | (cond ((stream-null? strm) stream-null) | |
321 | ((pred? (stream-car strm)) | |
322 | (stream-cons (stream-car strm) (recur (stream-cdr strm)))) | |
323 | (else (recur (stream-cdr strm)))))) | |
324 | ||
325 | (define (stream-fold proc base strm) | |
326 | (must procedure? proc 'stream-fold "non-procedural argument") | |
327 | (must stream? strm 'stream-fold "non-stream argument") | |
328 | (first-value (stream-fold-aux proc base strm #f))) | |
329 | ||
330 | (define stream-for-each | |
331 | (case-lambda | |
332 | ((proc strm) | |
333 | (must procedure? proc 'stream-for-each "non-procedural argument") | |
334 | (must stream? strm 'stream-for-each "non-stream argument") | |
335 | (do ((strm strm (stream-cdr strm))) | |
336 | ((stream-null? strm)) | |
337 | (proc (stream-car strm)))) | |
338 | ((proc strm . rest) | |
339 | (let ((strms (cons strm rest))) | |
340 | (must procedure? proc 'stream-for-each "non-procedural argument") | |
341 | (must-every stream? strms 'stream-for-each "non-stream argument") | |
342 | (do ((strms strms (map stream-cdr strms))) | |
343 | ((any stream-null? strms)) | |
344 | (apply proc (map stream-car strms))))))) | |
345 | ||
346 | (define* (stream-from first #:optional (step 1)) | |
347 | (must number? first 'stream-from "non-numeric starting number") | |
348 | (must number? step 'stream-from "non-numeric step size") | |
349 | (stream-let recur ((first first)) | |
350 | (stream-cons first (recur (+ first step))))) | |
351 | ||
352 | (define (stream-iterate proc base) | |
353 | (must procedure? proc 'stream-iterate "non-procedural argument") | |
354 | (stream-let recur ((base base)) | |
355 | (stream-cons base (recur (proc base))))) | |
356 | ||
357 | (define (stream-length strm) | |
358 | (must stream? strm 'stream-length "non-stream argument") | |
359 | (- -1 (third-value (stream-fold-aux #f #f strm -1)))) | |
360 | ||
361 | (define stream-map | |
362 | (case-lambda | |
363 | ((proc strm) | |
364 | (must procedure? proc 'stream-map "non-procedural argument") | |
365 | (must stream? strm 'stream-map "non-stream argument") | |
366 | (stream-let recur ((strm strm)) | |
367 | (if (stream-null? strm) stream-null | |
368 | (stream-cons (proc (stream-car strm)) | |
369 | (recur (stream-cdr strm)))))) | |
370 | ((proc strm . rest) | |
371 | (let ((strms (cons strm rest))) | |
372 | (must procedure? proc 'stream-map "non-procedural argument") | |
373 | (must-every stream? strms 'stream-map "non-stream argument") | |
374 | (stream-let recur ((strms strms)) | |
375 | (if (any stream-null? strms) stream-null | |
376 | (stream-cons (apply proc (map stream-car strms)) | |
377 | (recur (map stream-cdr strms))))))))) | |
378 | ||
379 | (define-syntax* (stream-match x) | |
380 | (define (make-matcher x) | |
381 | (syntax-case x () | |
382 | (() #'(? stream-null?)) | |
383 | (rest (identifier? #'rest) #'rest) | |
384 | ((var . rest) (identifier? #'var) | |
385 | (with-syntax ((next (make-matcher #'rest))) | |
386 | #'(? (negate stream-null?) | |
387 | (= stream-car var) | |
388 | (= stream-cdr next)))))) | |
389 | (define (make-guarded x fail) | |
390 | (syntax-case (list x fail) () | |
391 | (((expr) _) #'expr) | |
392 | (((guard expr) fail) #'(if guard expr (fail))))) | |
393 | ||
394 | (syntax-case x () | |
395 | ((_ strm-expr (pat . expr) ...) | |
396 | (with-syntax (((fail ...) (generate-temporaries #'(pat ...)))) | |
397 | (with-syntax (((matcher ...) (map make-matcher #'(pat ...))) | |
398 | ((expr ...) (map make-guarded #'(expr ...) #'(fail ...)))) | |
399 | #'(let ((strm strm-expr)) | |
400 | (must stream? strm 'stream-match "non-stream argument") | |
401 | (match strm (matcher (=> fail) expr) ...))))))) | |
402 | ||
403 | (define-syntax-rule (stream-of expr rest ...) | |
404 | (stream-of-aux expr stream-null rest ...)) | |
405 | ||
406 | (define-syntax stream-of-aux | |
407 | (syntax-rules (in is) | |
408 | ((_ expr base) | |
409 | (stream-cons expr base)) | |
410 | ((_ expr base (var in stream) rest ...) | |
411 | (stream-let recur ((strm stream)) | |
412 | (if (stream-null? strm) base | |
413 | (let ((var (stream-car strm))) | |
414 | (stream-of-aux expr (recur (stream-cdr strm)) rest ...))))) | |
415 | ((_ expr base (var is exp) rest ...) | |
416 | (let ((var exp)) (stream-of-aux expr base rest ...))) | |
417 | ((_ expr base pred? rest ...) | |
418 | (if pred? (stream-of-aux expr base rest ...) base)))) | |
419 | ||
420 | (define* (stream-range first past #:optional step) | |
421 | (must number? first 'stream-range "non-numeric starting number") | |
422 | (must number? past 'stream-range "non-numeric ending number") | |
423 | (when step | |
424 | (must number? step 'stream-range "non-numeric step size")) | |
425 | (let* ((step (or step (if (< first past) 1 -1))) | |
426 | (lt? (if (< 0 step) < >))) | |
427 | (stream-let recur ((first first)) | |
428 | (if (lt? first past) | |
429 | (stream-cons first (recur (+ first step))) | |
430 | stream-null)))) | |
431 | ||
432 | (define (stream-ref strm n) | |
433 | (must stream? strm 'stream-ref "non-stream argument") | |
434 | (must integer? n 'stream-ref "non-integer argument") | |
435 | (must exact? n 'stream-ref "inexact argument") | |
436 | (must-not negative? n 'stream-ref "negative argument") | |
437 | (let ((res (stream-drop n strm))) | |
438 | (must-not stream-null? res 'stream-ref "beyond end of stream") | |
439 | (stream-car res))) | |
440 | ||
441 | (define (stream-reverse strm) | |
442 | (must stream? strm 'stream-reverse "non-stream argument") | |
443 | (stream-do ((strm strm (stream-cdr strm)) | |
444 | (rev stream-null (stream-cons (stream-car strm) rev))) | |
445 | ((stream-null? strm) rev))) | |
446 | ||
447 | (define (stream-scan proc base strm) | |
448 | (must procedure? proc 'stream-scan "non-procedural argument") | |
449 | (must stream? strm 'stream-scan "non-stream argument") | |
450 | (stream-let recur ((base base) (strm strm)) | |
451 | (if (stream-null? strm) (stream base) | |
452 | (stream-cons base (recur (proc base (stream-car strm)) | |
453 | (stream-cdr strm)))))) | |
454 | ||
455 | (define (stream-take n strm) | |
456 | (must stream? strm 'stream-take "non-stream argument") | |
457 | (must integer? n 'stream-take "non-integer argument") | |
458 | (must exact? n 'stream-take "inexact argument") | |
459 | (must-not negative? n 'stream-take "negative argument") | |
460 | (stream-let recur ((n n) (strm strm)) | |
461 | (if (or (zero? n) (stream-null? strm)) stream-null | |
462 | (stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm)))))) | |
463 | ||
464 | (define (stream-take-while pred? strm) | |
465 | (must procedure? pred? 'stream-take-while "non-procedural argument") | |
466 | (must stream? strm 'stream-take-while "non-stream argument") | |
467 | (stream-let recur ((strm strm)) | |
468 | (cond ((stream-null? strm) stream-null) | |
469 | ((pred? (stream-car strm)) | |
470 | (stream-cons (stream-car strm) (recur (stream-cdr strm)))) | |
471 | (else stream-null)))) | |
472 | ||
473 | (define (stream-unfold mapper pred? generator base) | |
474 | (must procedure? mapper 'stream-unfold "non-procedural mapper") | |
475 | (must procedure? pred? 'stream-unfold "non-procedural pred?") | |
476 | (must procedure? generator 'stream-unfold "non-procedural generator") | |
477 | (stream-let recur ((base base)) | |
478 | (if (pred? base) | |
479 | (stream-cons (mapper base) (recur (generator base))) | |
480 | stream-null))) | |
481 | ||
482 | (define (stream-unfolds gen seed) | |
483 | (define-stream (generator-stream seed) | |
484 | (receive (next . items) (gen seed) | |
485 | (stream-cons (list->vector items) (generator-stream next)))) | |
486 | (define-stream (make-result-stream genstrm index) | |
487 | (define head (vector-ref (stream-car genstrm) index)) | |
488 | (define-stream (tail) (make-result-stream (stream-cdr genstrm) index)) | |
489 | (match head | |
490 | (() stream-null) | |
491 | (#f (tail)) | |
492 | ((item) (stream-cons item (tail))) | |
493 | ((? list? items) (stream-append (list->stream items) (tail))))) | |
494 | ||
495 | (must procedure? gen 'stream-unfolds "non-procedural argument") | |
496 | (let ((genstrm (generator-stream seed))) | |
497 | (apply values (list-tabulate (vector-length (stream-car genstrm)) | |
498 | (cut make-result-stream genstrm <>))))) | |
499 | ||
500 | (define (stream-zip strm . rest) | |
501 | (let ((strms (cons strm rest))) | |
502 | (must-every stream? strms 'stream-zip "non-stream argument") | |
503 | (stream-let recur ((strms strms)) | |
504 | (if (any stream-null? strms) stream-null | |
505 | (stream-cons (map stream-car strms) (recur (map stream-cdr strms))))))) |