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

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

SRFI 45 use rqrd extra level of indirection so dropped in favor of direct impl.

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