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

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

remove "primitives", replace inline type checks

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