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