source: project/release/4/srfi-41/trunk/streams-derived.scm @ 14192

Last change on this file since 14192 was 14192, checked in by Kon Lovett, 11 years ago

Update.

File size: 15.5 KB
Line 
1;;;; streams-derived.scm
2;;;; Kon Lovett, Apr '09
3
4; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA.  All rights
5; reserved.  Permission is hereby granted, free of charge, to any person obtaining a copy of
6; this software and associated documentation files (the "Software"), to deal in the Software
7; without restriction, including without limitation the rights to use, copy, modify, merge,
8; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
9; whom the Software is furnished to do so, subject to the following conditions: The above
10; copyright notice and this permission notice shall be included in all copies or substantial
11; portions of the Software.  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
12; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
13; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
14; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
15; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
16; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
17
18(declare
19  (usual-integrations)
20  (fixnum)
21  (inline)
22  (local)
23  (no-procedure-checks)
24  (bound-to-procedure
25    ##sys#signal-hook))
26
27(include "chicken-primitive-object-inlines")
28(include "streams-inlines")
29(include "inline-type-checks")
30
31;;;
32
33(define-inline (%check-streams loc strms nam)
34  (when (%any/1 not-stream? strms)
35    (error-stream loc strms nam) ) )
36
37(module streams-derived (;export
38  ;; SRFI 41 derived
39  define-stream stream stream-let
40  stream-match
41  stream-of
42  stream-constant
43  list->stream stream->list
44  port->stream
45  stream-length
46  stream-ref
47  stream-append stream-concat
48  stream-reverse
49  stream-drop stream-drop-while
50  stream-take stream-take-while
51  stream-filter stream-scan
52  stream-fold stream-for-each stream-map
53  stream-unfold stream-unfolds
54  stream-from stream-iterate stream-range
55  stream-zip
56  ;; WTF
57  $$stream-match-pattern
58  $$stream-match-test)
59
60(import scheme chicken
61  #;srfi-9 #;srfi-23
62  streams-primitive
63  (only type-errors
64    error-number error-procedure error-cardinal-integer error-input-port error-list))
65
66(require-library #;srfi-9 #;srfi-23 streams-primitive type-errors)
67
68;;;
69
70(define (not-stream? obj) (%not-stream? obj))
71
72;;;
73
74(define-syntax define-stream
75  (syntax-rules ()
76    ((define-stream (NAME . FORMAL) BODY0 BODY1 ...)
77     (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)) ) ) )
78
79(define-syntax stream
80  (syntax-rules ()
81    ((stream) stream-null)
82    ((stream X Y ...) (stream-cons X (stream Y ...)) ) ) )
83
84(define-syntax stream-let
85  (syntax-rules ()
86    ((stream-let TAG ((NAME VAL) ...) BODY0 BODY1 ...)
87     ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...) ) ) )
88
89;FIXME - this forces use of `_' identifier
90(define-syntax $$stream-match-pattern
91  (syntax-rules (_)
92
93    (($$stream-match-pattern STRM () (BINDING ...) BODY)
94     (and (stream-null? STRM)
95          (let (BINDING ...) BODY)) )
96
97    (($$stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
98     (and (stream-pair? STRM)
99          (let ((strm (stream-cdr STRM)))
100            ($$stream-match-pattern strm REST (BINDING ...) BODY))) )
101
102    (($$stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
103     (and (stream-pair? STRM)
104          (let ((temp (stream-car STRM))
105                (strm (stream-cdr STRM)))
106            ($$stream-match-pattern strm REST ((VAR temp) BINDING ...) BODY))) )
107
108    (($$stream-match-pattern STRM _ (BINDING ...) BODY)
109     (let (BINDING ...) BODY) )
110
111    (($$stream-match-pattern STRM VAR (BINDING ...) BODY)
112     (let ((VAR STRM) BINDING ...) BODY) ) ) )
113
114(define-syntax $$stream-match-test
115  (syntax-rules ()
116
117    (($$stream-match-test STRM (PATTERN FENDER EXPR))
118     ($$stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))) )
119
120    (($$stream-match-test STRM (PATTERN EXPR))
121     ($$stream-match-pattern STRM PATTERN () (list EXPR)) ) ) )
122
123(define-syntax stream-match
124  (syntax-rules ()
125    ((stream-match STRM-EXPR CLAUSE ...)
126     (let ((strm STRM-EXPR))
127       (cond ((not (stream? strm)) (error-stream 'stream-match strm 'stream))
128             (($$stream-match-test strm CLAUSE) => car) ...
129             (else (##sys#signal-hook #:error 'stream-match "no matching pattern")))) ) ) )
130
131(define-syntax stream-of
132  (syntax-rules (is in)
133
134    ((stream-of "aux" EXPR BASE)
135     (stream-cons EXPR BASE) )
136
137    ((stream-of "aux" EXPR BASE (VAR in STREAM) REST ...)
138     (stream-let loop ((strm STREAM))
139       (if (stream-null? strm) BASE
140           (let ((VAR (stream-car strm)))
141             (stream-of "aux" EXPR (loop (stream-cdr strm)) REST ...)))) )
142
143    ((stream-of "aux" EXPR BASE (VAR is EXP) REST ...)
144     (let ((VAR EXP)) (stream-of "aux" EXPR BASE REST ...)) )
145
146    ((stream-of "aux" EXPR BASE PRED? REST ...)
147     (if PRED? (stream-of "aux" EXPR BASE REST ...) BASE) )
148
149    ((stream-of EXPR REST ...)
150     (stream-of "aux" EXPR stream-null REST ...) ) ) )
151
152;;
153
154(define stream-constant
155  (stream-lambda objs
156    (cond ((%null? objs)
157            stream-null )
158          ((%null? (%cdr objs))
159            (stream-cons (%car objs) (stream-constant (%car objs))) )
160          (else
161            (stream-cons (%car objs)
162                         (apply stream-constant (append (%cdr objs) (%list/1 (%car objs))))) ) ) ) )
163
164(define (list->stream objects)
165
166  (define-stream (list->stream$ objs)
167    (if (%null? objs) stream-null
168        (stream-cons (%car objs) (list->stream$ (%cdr objs))) ) )
169
170  (%check-list 'list->stream objects 'objects)
171  (list->stream$ objects) )
172
173(define (stream->list . args)
174  (let* ((count (and (%fx< 1 (%list-length args)) (%car args)))
175         (streem (if count (%cadr args) (%car args))))
176    (%check-stream 'stream->list streem 'stream)
177    (when count (%check-cardinal-integer 'stream->list count 'count))
178    (let loop ((n (or count -1)) (strm streem))
179      (if (or (%fxzero? n) (stream-null? strm)) '()
180          (%cons (stream-car strm) (loop (%fxsub1 n) (stream-cdr strm))) ) ) ) )
181
182(define (port->stream . port)
183
184  (define-stream (port->stream$ p)
185    (let ((c (read-char p)))
186      (if (%eof-object? c) stream-null
187          (stream-cons c (port->stream$ p)) ) )  )
188
189  (let ((port (if (%null? port) (current-input-port) (%car port))))
190    (%check-input-port 'port->stream port 'port)
191    (port->stream$ port)) )
192
193(define (stream-length streem)
194  (%check-stream 'stream-length streem 'stream)
195  (let loop ((len 0) (strm streem))
196    (if (stream-null? strm) len
197        (loop (%fxadd1 len) (stream-cdr strm)) ) ) )
198
199(define (stream-ref streem index)
200  (%check-stream 'stream-ref streem 'stream)
201  (%check-cardinal-integer 'stream-ref index 'index)
202  (let loop ((strm streem) (n index))
203    (cond ((stream-null? strm)
204            (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) )
205          ((%fxzero? n)
206            (stream-car strm) )
207          (else
208            (loop (stream-cdr strm) (%fxsub1 n)) ) ) ) )
209
210(define (stream-reverse streem)
211
212  (define-stream (stream-reverse$ strm rev)
213    (if (stream-null? strm) rev
214        (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )
215
216  (%check-stream 'stream-reverse streem 'stream)
217  (stream-reverse$ streem stream-null) )
218
219(define (stream-append . streems)
220
221  (define-stream (stream-append$ strms)
222    (cond ((%null? (%cdr strms))
223            (%car strms) )
224          ((stream-null? (%car strms))
225            (stream-append$ (%cdr strms)) )
226          (else
227            (stream-cons (stream-car (%car strms))
228                         (stream-append$ (%cons (stream-cdr (%car strms)) (%cdr strms)))) ) ) )
229
230  (if (%null? streems) stream-null
231      (begin
232        (%check-streams 'stream-append streems 'stream)
233        (stream-append$ streems) ) ) )
234
235(define (stream-concat streem)
236
237  (define-stream (stream-concat$ strm)
238    (cond ((stream-null? strm)
239            stream-null )
240          ((not (stream? (stream-car strm)))
241            (error-stream 'stream-concat strm) )
242          ((stream-null? (stream-car strm))
243            (stream-concat$ (stream-cdr strm)) )
244          (else
245            (stream-cons (stream-car (stream-car strm))
246                         (stream-concat$ (stream-cons (stream-cdr (stream-car strm))
247                                                      (stream-cdr strm)))) ) ) )
248
249  (%check-stream 'stream-concat streem 'stream)
250  (stream-concat$ streem) )
251
252(define (stream-drop count streem)
253
254  (define-stream (stream-drop$ n strm)
255    (if (or (%fxzero? n) (stream-null? strm)) strm
256        (stream-drop$ (%fxsub1 n) (stream-cdr strm)) ) )
257
258  (%check-stream 'stream-drop streem 'stream)
259  (%check-cardinal-integer 'stream-drop count 'count)
260  (stream-drop$ count streem) )
261
262(define (stream-drop-while predicate? streem)
263
264  (define-stream (stream-drop-while$ strm)
265    (if (not (and (stream-pair? strm) (predicate? (stream-car strm)))) strm
266        (stream-drop-while$ (stream-cdr strm)) ) )
267
268  (%check-procedure 'stream-drop-while predicate? 'predicate?)
269  (%check-stream 'stream-drop-while streem 'stream)
270  (stream-drop-while$ streem) )
271
272(define (stream-take count streem)
273
274  (define-stream (stream-take$ n strm)
275    (if (or (stream-null? strm) (%fxzero? n)) stream-null
276        (stream-cons (stream-car strm) (stream-take$ (%fxsub1 n) (stream-cdr strm))) ) )
277
278  (%check-stream 'stream-take streem 'stream)
279  (%check-cardinal-integer 'stream-take count 'count)
280  (stream-take$ count streem) )
281
282(define (stream-take-while predicate? streem)
283
284 (define-stream (stream-take-while$ strm)
285    (cond ((stream-null? strm)
286            stream-null )
287          ((predicate? (stream-car strm))
288            (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))) )
289          (else
290            stream-null ) ) )
291
292  (%check-procedure 'stream-take-while predicate? 'predicate?)
293  (%check-stream 'stream-take-while streem 'stream)
294  (stream-take-while$ streem) )
295
296(define (stream-filter predicate? streem)
297
298  (define-stream (stream-filter$ strm)
299    (cond ((stream-null? strm)
300            stream-null )
301          ((predicate? (stream-car strm))
302            (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))) )
303          (else
304            (stream-filter$ (stream-cdr strm)) ) ) )
305
306  (%check-procedure 'stream-filter predicate? 'predicate?)
307  (%check-stream 'stream-filter streem 'stream)
308  (stream-filter$ streem) )
309
310(define (stream-scan function base streem)
311
312  (define-stream (stream-scan$ base strm)
313    (if (stream-null? strm) (stream base)
314        (stream-cons base
315                    (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) )
316
317  (%check-procedure 'stream-scan function 'function)
318  (%check-stream 'stream-scan streem 'stream)
319  (stream-scan$ base streem) )
320
321(define (stream-fold function base streem . streems)
322
323  (define (stream-folder base strms)
324    (if (%any/1 stream-null? strms) base
325        (stream-folder (apply function base (%list-map/1 stream-car strms))
326                       (%list-map/1 stream-cdr strms)) ) )
327
328  (%check-procedure 'stream-fold function 'function)
329  (let ((streems (%cons streem streems)))
330    (%check-streams 'stream-fold streems 'stream)
331    (stream-folder base streems) ) )
332
333(define (stream-for-each procedure streem . streems)
334
335  (define (stream-for-eacher strms)
336    (unless (%any/1 stream-null? strms)
337      (apply procedure (%list-map/1 stream-car strms))
338      (stream-for-eacher (%list-map/1 stream-cdr strms)) ) )
339
340  (%check-procedure 'stream-for-each procedure 'procedure)
341  (let ((streems (%cons streem streems)))
342    (%check-streams 'stream-for-each streems 'stream)
343    (stream-for-eacher streems) ) )
344
345(define (stream-map function streem . streems)
346
347  ; not tail-recursive to avoid `stream-reverse'
348  (define-stream (stream-map$ strms)
349    (if (%any/1 stream-null? strms) stream-null
350        (stream-cons (apply function (%list-map/1 stream-car strms))
351                     (stream-map$ (%list-map/1 stream-cdr strms))) ) )
352
353  (%check-procedure 'stream-map function 'function)
354  (let ((streems (%cons streem streems)))
355    (%check-streams 'stream-map streems 'stream)
356    (stream-map$ streems) ) )
357
358(define (stream-from first . step)
359
360  (define-stream (stream-from$ first delta)
361    (stream-cons first (stream-from$ (%fx+ first delta) delta)) )
362
363  (let ((delta (if (%null? step) 1 (%car step))))
364    (%check-number 'stream-from first 'first)
365    (%check-number 'stream-from delta 'delta)
366    (stream-from$ first delta) ) )
367
368(define (stream-iterate function base)
369
370  (define-stream (stream-iterate$ base)
371    (stream-cons base (stream-iterate$ (function base))) )
372
373  (%check-procedure 'stream-iterate function 'function)
374  (stream-iterate$ base) )
375
376(define (stream-range first past . step)
377
378  (define-stream (stream-range$ first past delta lt?)
379    (if (not (lt? first past)) stream-null
380        (stream-cons first (stream-range$ (%fx+ first delta) past delta lt?)) ) )
381
382  (%check-number 'stream-range first 'first)
383  (%check-number 'stream-range past 'past)
384  (let ((delta (cond ((%pair? step) (%car step)) ((< first past) 1) (else -1))))
385    (%check-number 'stream-range delta 'delta)
386    (let ((lt? (if (< 0 delta) < >)))
387      (stream-range$ first past delta lt?) ) ) )
388
389(define (stream-unfold mapper predicate? generator base)
390
391  (define-stream (stream-unfold$ base)
392    (if (not (predicate? base)) stream-null
393        (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )
394
395  (%check-procedure 'stream-unfold mapper 'mapper)
396  (%check-procedure 'stream-unfold predicate? 'predicate?)
397  (%check-procedure 'stream-unfold generator 'generator)
398  (stream-unfold$ base) )
399
400(define (stream-unfolds generator seed)
401
402  (define (len-values)
403    (call-with-values
404      (lambda () (generator seed))
405      (lambda vs (%fxsub1 (length vs)))) )
406
407  (define-stream (unfold-result-stream seed)
408    (call-with-values
409      (lambda () (generator seed))
410      (lambda (next . results)
411        (stream-cons results (unfold-result-stream next)))) )
412
413  (define-stream (result-stream->output-stream result-stream i)
414    (let ((result (%list-ref (stream-car result-stream) (%fxsub1 i))))
415      (cond ((%pair? result)
416             (stream-cons (%car result)
417                          (result-stream->output-stream (stream-cdr result-stream) i)) )
418            ((not result)
419             (result-stream->output-stream (stream-cdr result-stream) i) )
420            ((%null? result)
421             stream-null )
422            (else
423             (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) )
424
425  (define (result-stream->output-streams result-stream)
426    (let loop ((i (len-values)) (outputs '()))
427      (if (%fxzero? i) (apply values outputs)
428          (loop (%fxsub1 i) (%cons (result-stream->output-stream result-stream i) outputs)) ) ) )
429
430  (%check-procedure 'stream-unfolds generator 'generator)
431  (result-stream->output-streams (unfold-result-stream seed)) )
432
433(define (stream-zip streem . streems)
434
435  (define-stream (stream-zip$ strms)
436    (if (%any/1 stream-null? strms) stream-null
437        (stream-cons (%list-map/1 stream-car strms)
438                     (stream-zip$ (%list-map/1 stream-cdr strms))) ) )
439
440  (let ((streems (%cons streem streems)))
441    (%check-streams 'stream-zip streems 'stream)
442    (stream-zip$ streems) ) )
443
444) ;module streams-derived
Note: See TracBrowser for help on using the repository browser.