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

Last change on this file since 14571 was 14571, checked in by Kon Lovett, 10 years ago

Dropped some explicit inlines. Identifiers that are indirectly used (macros & procs) need to be explicitly exported. Ex: the stream-match macros. Also, streams needs $$make-stream-pare explicitly exported by primitives.

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