;;;; streams.derived.scm -*- Scheme -*- ; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. All rights ; reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of ; this software and associated documentation files (the "Software"), to deal in the Software ; without restriction, including without limitation the rights to use, copy, modify, merge, ; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to ; whom the Software is furnished to do so, subject to the following conditions: The above ; copyright notice and this permission notice shall be included in all copies or substantial ; portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS ; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF ; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR ; THE USE OR OTHER DEALINGS IN THE SOFTWARE. (declare (bound-to-procedure ##sys#signal-hook)) (module (streams derived) (;export ;srfi-41 derived define-stream stream stream-let stream-match stream-of stream-constant list->stream stream->list port->stream stream-length stream-ref stream-append stream-concat stream-reverse stream-drop stream-drop-while stream-take stream-take-while stream-filter stream-scan stream-fold stream-for-each stream-map stream-unfold stream-unfolds stream-from stream-iterate stream-range stream-zip ;explicit export: compiler cannot follow syntax >-> syntax stream-match-test stream-match-pattern) (import scheme (chicken base) (chicken fixnum) (chicken syntax) (srfi 9) (srfi 23) (only (srfi-1) any) (only type-checks check-number check-procedure check-natural-integer check-input-port check-list) (streams primitive)) ;;; (define-inline (%check-streams loc strms #!optional argnam) (when (null? strms) (error loc "no stream arguments" strms)) (for-each (cut check-stream loc <> argnam) strms) strms ) ;;fx-inlines.scm (define (fxzero? n) (fx= 0 n)) (define (fxadd1 n) (fx+ n 1)) (define (fxsub1 n) (fx- n 1)) ;;; (define-syntax define-stream (syntax-rules () ((define-stream (?name . ?formals) ?body0 ?body1 ...) (define ?name (stream-lambda ?formals ?body0 ?body1 ...)) ) ) ) (define-syntax stream (syntax-rules () ((stream) stream-null) ((stream X Y ...) (stream-cons X (stream Y ...)) ) ) ) (define-syntax stream-let (syntax-rules () ((stream-let ?tag ((?name ?val) ...) ?body0 ?body1 ...) ((letrec ((?tag (stream-lambda (?name ...) ?body0 ?body1 ...))) ?tag) ?val ...) ) ) ) ;FIXME - this forces use of `_' identifier (define-syntax stream-match-pattern (syntax-rules (_) ; ((stream-match-pattern ?strm () (?binding ...) ?body) (and (stream-null? ?strm) (let (?binding ...) ?body)) ) ; ((stream-match-pattern ?strm (_ . ?rest) (?binding ...) ?body) (and (stream-pair? ?strm) (let ((strm (stream-cdr ?strm))) (stream-match-pattern strm ?rest (?binding ...) ?body))) ) ; ((stream-match-pattern ?strm (?var . ?rest) (?binding ...) ?body) (and (stream-pair? ?strm) (let ((temp (stream-car ?strm)) (strm (stream-cdr ?strm))) (stream-match-pattern strm ?rest ((?var temp) ?binding ...) ?body))) ) ; ((stream-match-pattern ?strm _ (?binding ...) ?body) (let (?binding ...) ?body) ) ; ((stream-match-pattern ?strm ?var (?binding ...) ?body) (let ((?var ?strm) ?binding ...) ?body) ) ) ) (define-syntax stream-match-test (syntax-rules () ; ((stream-match-test ?strm (?pattern ?fender ?expr)) (stream-match-pattern ?strm ?pattern () (and ?fender (list ?expr))) ) ; ((stream-match-test ?strm (?pattern ?expr)) (stream-match-pattern ?strm ?pattern () (list ?expr)) ) ) ) (define-syntax stream-match (syntax-rules () ((stream-match ?strm-expr ?clause ...) (let ((strm ?strm-expr)) (cond ((not (stream? strm)) (error-stream 'stream-match strm 'stream)) ((stream-match-test strm ?clause) => car) ... (else (error 'stream-match "no matching pattern")))) ) ) ) (define-syntax stream-of (syntax-rules (is in) ; ((stream-of "aux" ?expr ?base) (stream-cons ?expr ?base) ) ; ((stream-of "aux" ?expr ?base (?var in ?strm) ?rest ...) (stream-let loop ((strm ?strm)) (if (stream-null? strm) ?base (let ((?var (stream-car strm))) (stream-of "aux" ?expr (loop (stream-cdr strm)) ?rest ...)))) ) ; ((stream-of "aux" ?expr ?base (?var is ?exp) ?rest ...) (let ((?var ?exp)) (stream-of "aux" ?expr ?base ?rest ...)) ) ; ((stream-of "aux" ?expr ?base ?pred? ?rest ...) (if ?pred? (stream-of "aux" ?expr ?base ?rest ...) ?base) ) ; ((stream-of ?expr ?rest ...) (stream-of "aux" ?expr stream-null ?rest ...) ) ) ) ;; (define stream-constant (stream-lambda objs (cond ((null? objs) stream-null ) ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))) ) (else (stream-cons (car objs) (apply stream-constant (append (cdr objs) (list (car objs))))) ) ) ) ) (define (list->stream objects) ; (define-stream (list->stream$ objs) (if (null? objs) stream-null (stream-cons (car objs) (list->stream$ (cdr objs))) ) ) ; (list->stream$ (check-list 'list->stream objects 'objects)) ) (define (stream->list . args) (let* ((count (and (fx< 1 (length args)) (check-natural-integer 'stream->list (car args) 'count))) (strm (if count (cadr args) (car args))) (count (or count -1)) ) (let loop ((n count) (strm (check-stream 'stream->list strm 'stream))) (if (or (fxzero? n) (stream-null? strm)) '() (cons (stream-car strm) (loop (fxsub1 n) (stream-cdr strm))) ) ) ) ) (define (port->stream . port) ; (define-stream (port->stream$ p) (let ((c (read-char p))) (if (eof-object? c) stream-null (stream-cons c (port->stream$ p)) ) ) ) ; (let ((port (if (null? port) (current-input-port) (car port)))) (port->stream$ (check-input-port 'port->stream port 'port))) ) (define (stream-length strm) (let loop ((len 0) (strm (check-stream 'stream-length strm 'stream))) (if (stream-null? strm) len (loop (fxadd1 len) (stream-cdr strm)) ) ) ) (define (stream-ref strm index) (let loop ((strm (check-stream 'stream-ref strm 'stream)) (n (check-natural-integer 'stream-ref index 'index))) (cond ((stream-null? strm) (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) ) ((fxzero? n) (stream-car strm) ) (else (loop (stream-cdr strm) (fxsub1 n)) ) ) ) ) (define (stream-reverse strm) ; (define-stream (stream-reverse$ strm rev) (if (stream-null? strm) rev (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) ) ; (stream-reverse$ (check-stream 'stream-reverse strm 'stream) stream-null) ) (define (stream-append . strms) ; (define-stream (stream-append$ strms) (cond ((null? (cdr strms)) (car strms) ) ((stream-null? (car strms)) (stream-append$ (cdr strms)) ) (else (stream-cons (stream-car (car strms)) (stream-append$ (cons (stream-cdr (car strms)) (cdr strms)))) ) ) ) ; (if (null? strms) stream-null (stream-append$ (%check-streams 'stream-append strms 'stream)) ) ) (define (stream-concat strm) ; (define-stream (stream-concat$ strm) (cond ((stream-null? strm) stream-null ) ((not (stream? (stream-car strm))) (error-stream 'stream-concat strm) ) ((stream-null? (stream-car strm)) (stream-concat$ (stream-cdr strm)) ) (else (stream-cons (stream-car (stream-car strm)) (stream-concat$ (stream-cons (stream-cdr (stream-car strm)) (stream-cdr strm)))) ) ) ) ; (stream-concat$ (check-stream 'stream-concat strm 'stream)) ) (define (stream-drop count strm) ; (define-stream (stream-drop$ n strm) (if (or (fxzero? n) (stream-null? strm)) strm (stream-drop$ (fxsub1 n) (stream-cdr strm)) ) ) ; (stream-drop$ (check-natural-integer 'stream-drop count 'count) (check-stream 'stream-drop strm 'stream)) ) (define (stream-drop-while predicate? strm) ; (define-stream (stream-drop-while$ strm) (if (not (and (stream-pair? strm) (predicate? (stream-car strm)))) strm (stream-drop-while$ (stream-cdr strm)) ) ) ; (check-procedure 'stream-drop-while predicate? 'predicate?) (stream-drop-while$ (check-stream 'stream-drop-while strm 'stream)) ) (define (stream-take count strm) ; (define-stream (stream-take$ n strm) (if (or (stream-null? strm) (fxzero? n)) stream-null (stream-cons (stream-car strm) (stream-take$ (fxsub1 n) (stream-cdr strm))) ) ) ; (stream-take$ (check-natural-integer 'stream-take count 'count) (check-stream 'stream-take strm 'stream)) ) (define (stream-take-while predicate? strm) ; (define-stream (stream-take-while$ strm) (cond ((stream-null? strm) stream-null ) ((predicate? (stream-car strm)) (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))) ) (else stream-null ) ) ) ; (check-procedure 'stream-take-while predicate? 'predicate?) (stream-take-while$ (check-stream 'stream-take-while strm 'stream)) ) (define (stream-filter predicate? strm) ; (define-stream (stream-filter$ strm) (cond ((stream-null? strm) stream-null ) ((predicate? (stream-car strm)) (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))) ) (else (stream-filter$ (stream-cdr strm)) ) ) ) ; (check-procedure 'stream-filter predicate? 'predicate?) (stream-filter$ (check-stream 'stream-filter strm 'stream)) ) (define (stream-scan function base strm) ; (define-stream (stream-scan$ base strm) (if (stream-null? strm) (stream base) (stream-cons base (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) ) ; (check-procedure 'stream-scan function 'function) (stream-scan$ base (check-stream 'stream-scan strm 'stream)) ) (define (stream-fold function base . strms) ; (define (stream-folder base strms) (if (any stream-null? strms) base (stream-folder (apply function base (map stream-car strms)) (map stream-cdr strms)) ) ) ; (check-procedure 'stream-fold function 'function) (stream-folder base (%check-streams 'stream-fold strms 'stream)) ) (define (stream-for-each procedure . strms) ; (define (stream-for-eacher strms) (unless (any stream-null? strms) (apply procedure (map stream-car strms)) (stream-for-eacher (map stream-cdr strms)) ) ) ; (check-procedure 'stream-for-each procedure 'procedure) (stream-for-eacher (%check-streams 'stream-for-each strms 'stream)) ) (define (stream-map function . strms) ; ; not tail-recursive to avoid `stream-reverse' (define-stream (stream-map$ strms) (if (any stream-null? strms) stream-null (stream-cons (apply function (map stream-car strms)) (stream-map$ (map stream-cdr strms))) ) ) ; (check-procedure 'stream-map function 'function) (stream-map$ (%check-streams 'stream-map strms 'stream)) ) (define (stream-from first . step) ; (define-stream (stream-from$ first delta) (stream-cons first (stream-from$ (fx+ first delta) delta)) ) ; (let ((delta (if (null? step) 1 (car step)))) (stream-from$ (check-number 'stream-from first 'first) (check-number 'stream-from delta 'delta)) ) ) (define (stream-iterate function base) ; (define-stream (stream-iterate$ base) (stream-cons base (stream-iterate$ (function base))) ) ; (check-procedure 'stream-iterate function 'function) (stream-iterate$ base) ) (define (stream-range first past . step) ; (define-stream (stream-range$ first past delta lt?) (if (not (lt? first past)) stream-null (stream-cons first (stream-range$ (fx+ first delta) past delta lt?)) ) ) ; (check-number 'stream-range first 'first) (check-number 'stream-range past 'past) (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) (check-number 'stream-range delta 'delta) (let ((lt? (if (< 0 delta) < >))) (stream-range$ first past delta lt?) ) ) ) (define (stream-unfold mapper predicate? generator base) ; (define-stream (stream-unfold$ base) (if (not (predicate? base)) stream-null (stream-cons (mapper base) (stream-unfold$ (generator base))) ) ) ; (check-procedure 'stream-unfold mapper 'mapper) (check-procedure 'stream-unfold predicate? 'predicate?) (check-procedure 'stream-unfold generator 'generator) (stream-unfold$ base) ) (define (stream-unfolds generator seed) ; (define (len-values) (call-with-values (lambda () (generator seed)) (lambda vs (fxsub1 (length vs)))) ) ; (define-stream (unfold-result-stream seed) (call-with-values (lambda () (generator seed)) (lambda (next . results) (stream-cons results (unfold-result-stream next)))) ) ; (define-stream (result-stream->output-stream result-stream i) (let ((result (list-ref (stream-car result-stream) (fxsub1 i)))) (cond ((pair? result) (stream-cons (car result) (result-stream->output-stream (stream-cdr result-stream) i)) ) ((not result) (result-stream->output-stream (stream-cdr result-stream) i) ) ((null? result) stream-null ) (else (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) ) ; (define (result-stream->output-strms result-stream) (let loop ((i (len-values)) (outputs '())) (if (fxzero? i) (apply values outputs) (loop (fxsub1 i) (cons (result-stream->output-stream result-stream i) outputs)) ) ) ) ; (check-procedure 'stream-unfolds generator 'generator) (result-stream->output-strms (unfold-result-stream seed)) ) (define (stream-zip . strms) ; (define-stream (stream-zip$ strms) (if (any stream-null? strms) stream-null (stream-cons (map stream-car strms) (stream-zip$ (map stream-cdr strms))) ) ) ; (stream-zip$ (%check-streams 'stream-zip strms 'stream)) ) ) ;module (streams derived)