source: project/release/5/srfi-41/trunk/streams-derived.scm @ 39709

Last change on this file since 39709 was 39709, checked in by Kon Lovett, 2 months ago

remove "primitives"

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