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

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

Renamed obj to item to escape define-inline "coloring" issue.

File size: 15.2 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(module streams-derived (;export
32  ;; SRFI 41 derived
33  define-stream stream stream-let
34  stream-match ;($$stream-match-test)
35  stream-of
36  stream-constant
37  list->stream stream->list
38  port->stream
39  stream-length
40  stream-ref
41  stream-append stream-concat
42  stream-reverse
43  stream-drop stream-drop-while
44  stream-take stream-take-while
45  stream-filter stream-scan
46  stream-fold stream-for-each stream-map
47  stream-unfold stream-unfolds
48  stream-from stream-iterate stream-range
49  stream-zip
50  ;; WTF
51  $$stream-match-test ;($$stream-match-pattern)
52  $$stream-match-pattern)
53
54(import scheme chicken
55  #;srfi-9 #;srfi-23
56  streams-primitive
57  (only type-errors
58    error-number error-procedure error-cardinal-integer error-input-port error-list))
59
60(require-library #;srfi-9 #;srfi-23 streams-primitive type-errors)
61
62;;;
63
64(define-syntax define-stream
65  (syntax-rules ()
66    ((define-stream (NAME . FORMAL) BODY0 BODY1 ...)
67     (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)) ) ) )
68
69(define-syntax stream
70  (syntax-rules ()
71    ((stream) stream-null)
72    ((stream X Y ...) (stream-cons X (stream Y ...)) ) ) )
73
74(define-syntax stream-let
75  (syntax-rules ()
76    ((stream-let TAG ((NAME VAL) ...) BODY0 BODY1 ...)
77     ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...) ) ) )
78
79;FIXME - this forces use of `_' identifier
80(define-syntax $$stream-match-pattern
81  (syntax-rules (_)
82
83    (($$stream-match-pattern STRM () (BINDING ...) BODY)
84     (and (stream-null? STRM)
85          (let (BINDING ...) BODY)) )
86
87    (($$stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
88     (and (stream-pair? STRM)
89          (let ((strm (stream-cdr STRM)))
90            ($$stream-match-pattern strm REST (BINDING ...) BODY))) )
91
92    (($$stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
93     (and (stream-pair? STRM)
94          (let ((temp (stream-car STRM))
95                (strm (stream-cdr STRM)))
96            ($$stream-match-pattern strm REST ((VAR temp) BINDING ...) BODY))) )
97
98    (($$stream-match-pattern STRM _ (BINDING ...) BODY)
99     (let (BINDING ...) BODY) )
100
101    (($$stream-match-pattern STRM VAR (BINDING ...) BODY)
102     (let ((VAR STRM) BINDING ...) BODY) ) ) )
103
104(define-syntax $$stream-match-test
105  (syntax-rules ()
106
107    (($$stream-match-test STRM (PATTERN FENDER EXPR))
108     ($$stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))) )
109
110    (($$stream-match-test STRM (PATTERN EXPR))
111     ($$stream-match-pattern STRM PATTERN () (list EXPR)) ) ) )
112
113(define-syntax stream-match
114  (syntax-rules ()
115    ((stream-match STRM-EXPR CLAUSE ...)
116     (let ((strm STRM-EXPR))
117       (cond ((not (stream? strm)) (error-stream 'stream-match strm 'stream))
118             (($$stream-match-test strm CLAUSE) => car) ...
119             (else (##sys#signal-hook #:error 'stream-match "no matching pattern")))) ) ) )
120
121(define-syntax stream-of
122  (syntax-rules (is in)
123
124    ((stream-of "aux" EXPR BASE)
125     (stream-cons EXPR BASE) )
126
127    ((stream-of "aux" EXPR BASE (VAR in STREAM) REST ...)
128     (stream-let loop ((strm STREAM))
129       (if (stream-null? strm) BASE
130           (let ((VAR (stream-car strm)))
131             (stream-of "aux" EXPR (loop (stream-cdr strm)) REST ...)))) )
132
133    ((stream-of "aux" EXPR BASE (VAR is EXP) REST ...)
134     (let ((VAR EXP)) (stream-of "aux" EXPR BASE REST ...)) )
135
136    ((stream-of "aux" EXPR BASE PRED? REST ...)
137     (if PRED? (stream-of "aux" EXPR BASE REST ...) BASE) )
138
139    ((stream-of EXPR REST ...)
140     (stream-of "aux" EXPR stream-null REST ...) ) ) )
141
142;;
143
144(define stream-constant
145  (stream-lambda objs
146    (cond ((%null? objs)
147            stream-null )
148          ((%null? (%cdr objs))
149            (stream-cons (%car objs) (stream-constant (%car objs))) )
150          (else
151            (stream-cons (%car objs)
152                         (apply stream-constant (append (%cdr objs) (%list/1 (%car objs))))) ) ) ) )
153
154(define (list->stream objects)
155
156  (define-stream (list->stream$ objs)
157    (if (%null? objs) stream-null
158        (stream-cons (%car objs) (list->stream$ (%cdr objs))) ) )
159
160  (%check-list 'list->stream objects 'objects)
161  (list->stream$ objects) )
162
163(define (stream->list . args)
164  (let* ((count (and (%fx< 1 (%list-length args)) (%car args)))
165         (streem (if count (%cadr args) (%car args))))
166    (%check-stream 'stream->list streem 'stream)
167    (when count (%check-cardinal-integer 'stream->list count 'count))
168    (let loop ((n (or count -1)) (strm streem))
169      (if (or (%fxzero? n) (stream-null? strm)) '()
170          (%cons (stream-car strm) (loop (%fxsub1 n) (stream-cdr strm))) ) ) ) )
171
172(define (port->stream . port)
173
174  (define-stream (port->stream$ p)
175    (let ((c (read-char p)))
176      (if (%eof-object? c) stream-null
177          (stream-cons c (port->stream$ p)) ) )  )
178
179  (let ((port (if (%null? port) (current-input-port) (%car port))))
180    (%check-input-port 'port->stream port 'port)
181    (port->stream$ port)) )
182
183(define (stream-length streem)
184  (%check-stream 'stream-length streem 'stream)
185  (let loop ((len 0) (strm streem))
186    (if (stream-null? strm) len
187        (loop (%fxadd1 len) (stream-cdr strm)) ) ) )
188
189(define (stream-ref streem index)
190  (%check-stream 'stream-ref streem 'stream)
191  (%check-cardinal-integer 'stream-ref index 'index)
192  (let loop ((strm streem) (n index))
193    (cond ((stream-null? strm)
194            (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) )
195          ((%fxzero? n)
196            (stream-car strm) )
197          (else
198            (loop (stream-cdr strm) (%fxsub1 n)) ) ) ) )
199
200(define (stream-reverse streem)
201
202  (define-stream (stream-reverse$ strm rev)
203    (if (stream-null? strm) rev
204        (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )
205
206  (%check-stream 'stream-reverse streem 'stream)
207  (stream-reverse$ streem stream-null) )
208
209(define (stream-append . streems)
210
211  (define-stream (stream-append$ strms)
212    (cond ((%null? (%cdr strms))
213            (%car strms) )
214          ((stream-null? (%car strms))
215            (stream-append$ (%cdr strms)) )
216          (else
217            (stream-cons (stream-car (%car strms))
218                         (stream-append$ (%cons (stream-cdr (%car strms)) (%cdr strms)))) ) ) )
219
220  (if (%null? streems) stream-null
221      (begin
222        (%check-streams 'stream-append streems 'stream)
223        (stream-append$ streems) ) ) )
224
225(define (stream-concat streem)
226
227  (define-stream (stream-concat$ strm)
228    (cond ((stream-null? strm)
229            stream-null )
230          ((not (stream? (stream-car strm)))
231            (error-stream 'stream-concat strm) )
232          ((stream-null? (stream-car strm))
233            (stream-concat$ (stream-cdr strm)) )
234          (else
235            (stream-cons (stream-car (stream-car strm))
236                         (stream-concat$ (stream-cons (stream-cdr (stream-car strm))
237                                                      (stream-cdr strm)))) ) ) )
238
239  (%check-stream 'stream-concat streem 'stream)
240  (stream-concat$ streem) )
241
242(define (stream-drop count streem)
243
244  (define-stream (stream-drop$ n strm)
245    (if (or (%fxzero? n) (stream-null? strm)) strm
246        (stream-drop$ (%fxsub1 n) (stream-cdr strm)) ) )
247
248  (%check-stream 'stream-drop streem 'stream)
249  (%check-cardinal-integer 'stream-drop count 'count)
250  (stream-drop$ count streem) )
251
252(define (stream-drop-while predicate? streem)
253
254  (define-stream (stream-drop-while$ strm)
255    (if (not (and (stream-pair? strm) (predicate? (stream-car strm)))) strm
256        (stream-drop-while$ (stream-cdr strm)) ) )
257
258  (%check-procedure 'stream-drop-while predicate? 'predicate?)
259  (%check-stream 'stream-drop-while streem 'stream)
260  (stream-drop-while$ streem) )
261
262(define (stream-take count streem)
263
264  (define-stream (stream-take$ n strm)
265    (if (or (stream-null? strm) (%fxzero? n)) stream-null
266        (stream-cons (stream-car strm) (stream-take$ (%fxsub1 n) (stream-cdr strm))) ) )
267
268  (%check-stream 'stream-take streem 'stream)
269  (%check-cardinal-integer 'stream-take count 'count)
270  (stream-take$ count streem) )
271
272(define (stream-take-while predicate? streem)
273
274 (define-stream (stream-take-while$ strm)
275    (cond ((stream-null? strm)
276            stream-null )
277          ((predicate? (stream-car strm))
278            (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))) )
279          (else
280            stream-null ) ) )
281
282  (%check-procedure 'stream-take-while predicate? 'predicate?)
283  (%check-stream 'stream-take-while streem 'stream)
284  (stream-take-while$ streem) )
285
286(define (stream-filter predicate? streem)
287
288  (define-stream (stream-filter$ strm)
289    (cond ((stream-null? strm)
290            stream-null )
291          ((predicate? (stream-car strm))
292            (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))) )
293          (else
294            (stream-filter$ (stream-cdr strm)) ) ) )
295
296  (%check-procedure 'stream-filter predicate? 'predicate?)
297  (%check-stream 'stream-filter streem 'stream)
298  (stream-filter$ streem) )
299
300(define (stream-scan function base streem)
301
302  (define-stream (stream-scan$ base strm)
303    (if (stream-null? strm) (stream base)
304        (stream-cons base
305                    (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) )
306
307  (%check-procedure 'stream-scan function 'function)
308  (%check-stream 'stream-scan streem 'stream)
309  (stream-scan$ base streem) )
310
311(define (stream-fold function base . streems)
312
313  (define (stream-folder base strms)
314    (if (%any/1 stream-null? strms) base
315        (stream-folder (apply function base (%list-map/1 stream-car strms))
316                       (%list-map/1 stream-cdr strms)) ) )
317
318  (%check-procedure 'stream-fold function 'function)
319  (%check-streams 'stream-fold streems 'stream)
320  (stream-folder base streems) )
321
322(define (stream-for-each procedure . streems)
323
324  (define (stream-for-eacher strms)
325    (unless (%any/1 stream-null? strms)
326      (apply procedure (%list-map/1 stream-car strms))
327      (stream-for-eacher (%list-map/1 stream-cdr strms)) ) )
328
329  (%check-procedure 'stream-for-each procedure 'procedure)
330  (%check-streams 'stream-for-each streems 'stream)
331  (stream-for-eacher streems) )
332
333(define (stream-map function . streems)
334
335  ; not tail-recursive to avoid `stream-reverse'
336  (define-stream (stream-map$ strms)
337    (if (%any/1 stream-null? strms) stream-null
338        (stream-cons (apply function (%list-map/1 stream-car strms))
339                     (stream-map$ (%list-map/1 stream-cdr strms))) ) )
340
341  (%check-procedure 'stream-map function 'function)
342  (%check-streams 'stream-map streems 'stream)
343  (stream-map$ streems) )
344
345(define (stream-from first . step)
346
347  (define-stream (stream-from$ first delta)
348    (stream-cons first (stream-from$ (%fx+ first delta) delta)) )
349
350  (let ((delta (if (%null? step) 1 (%car step))))
351    (%check-number 'stream-from first 'first)
352    (%check-number 'stream-from delta 'delta)
353    (stream-from$ first delta) ) )
354
355(define (stream-iterate function base)
356
357  (define-stream (stream-iterate$ base)
358    (stream-cons base (stream-iterate$ (function base))) )
359
360  (%check-procedure 'stream-iterate function 'function)
361  (stream-iterate$ base) )
362
363(define (stream-range first past . step)
364
365  (define-stream (stream-range$ first past delta lt?)
366    (if (not (lt? first past)) stream-null
367        (stream-cons first (stream-range$ (%fx+ first delta) past delta lt?)) ) )
368
369  (%check-number 'stream-range first 'first)
370  (%check-number 'stream-range past 'past)
371  (let ((delta (cond ((%pair? step) (%car step)) ((< first past) 1) (else -1))))
372    (%check-number 'stream-range delta 'delta)
373    (let ((lt? (if (< 0 delta) < >)))
374      (stream-range$ first past delta lt?) ) ) )
375
376(define (stream-unfold mapper predicate? generator base)
377
378  (define-stream (stream-unfold$ base)
379    (if (not (predicate? base)) stream-null
380        (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )
381
382  (%check-procedure 'stream-unfold mapper 'mapper)
383  (%check-procedure 'stream-unfold predicate? 'predicate?)
384  (%check-procedure 'stream-unfold generator 'generator)
385  (stream-unfold$ base) )
386
387(define (stream-unfolds generator seed)
388
389  (define (len-values)
390    (call-with-values
391      (lambda () (generator seed))
392      (lambda vs (%fxsub1 (%length vs)))) )
393
394  (define-stream (unfold-result-stream seed)
395    (call-with-values
396      (lambda () (generator seed))
397      (lambda (next . results)
398        (stream-cons results (unfold-result-stream next)))) )
399
400  (define-stream (result-stream->output-stream result-stream i)
401    (let ((result (%list-ref (stream-car result-stream) (%fxsub1 i))))
402      (cond ((%pair? result)
403             (stream-cons (%car result)
404                          (result-stream->output-stream (stream-cdr result-stream) i)) )
405            ((not result)
406             (result-stream->output-stream (stream-cdr result-stream) i) )
407            ((%null? result)
408             stream-null )
409            (else
410             (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) )
411
412  (define (result-stream->output-streams result-stream)
413    (let loop ((i (len-values)) (outputs '()))
414      (if (%fxzero? i) (apply values outputs)
415          (loop (%fxsub1 i) (%cons (result-stream->output-stream result-stream i) outputs)) ) ) )
416
417  (%check-procedure 'stream-unfolds generator 'generator)
418  (result-stream->output-streams (unfold-result-stream seed)) )
419
420(define (stream-zip . streems)
421
422  (define-stream (stream-zip$ strms)
423    (if (%any/1 stream-null? strms) stream-null
424        (stream-cons (%list-map/1 stream-car strms)
425                     (stream-zip$ (%list-map/1 stream-cdr strms))) ) )
426
427  (%check-streams 'stream-zip streems 'stream)
428  (stream-zip$ streems) )
429
430) ;module streams-derived
Note: See TracBrowser for help on using the repository browser.