Changeset 39998 in project


Ignore:
Timestamp:
04/13/21 23:47:57 (4 weeks ago)
Author:
Kon Lovett
Message:

reexport style

Location:
release/5/srfi-41/trunk
Files:
5 deleted
13 edited

Legend:

Unmodified
Added
Removed
  • release/5/srfi-41/trunk/srfi-41.egg

    r39989 r39998  
    22
    33((synopsis "SRFI 41 (Streams)")
    4  (version "2.1.0")
     4 (version "2.1.1")
    55 (category data)
    66 (author "Philip L. Bewig, for CHICKEN by Kon Lovett")
     
    1313    (types-file)
    1414    (component-dependencies streams)
    15     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     15    (csc-options "-O3" "-d1" "-strict-types"
     16      "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings"))
    1617  (extension streams
    1718    (types-file)
    1819    (component-dependencies streams.primitive streams.derived)
    19     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     20    (csc-options "-O3" "-d1" "-strict-types"
     21      "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings"))
    2022  (extension streams-primitive
    2123    (types-file)
     24    (component-dependencies streams.primitive)
    2225    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    2326  (extension streams-derived
    2427    (types-file)
    25     (component-dependencies streams-primitive)
     28    (component-dependencies streams.derived)
    2629    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    2730  (extension streams-utils
    2831    (types-file)
    29     (component-dependencies streams)
    30     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     32    (component-dependencies streams.utils)
     33    (csc-options "-O3" "-d1" "-strict-types"
     34      "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings"))
    3135  (extension streams-math
    3236    (types-file)
    33     (component-dependencies streams streams-utils)
    34     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     37    (component-dependencies streams.math)
     38    (csc-options "-O3" "-d1" "-strict-types"
     39      "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings"))
    3540  (extension streams-queue
    3641    (types-file)
    37     (component-dependencies streams)
    38     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     42    (component-dependencies streams.queue)
     43    (csc-options "-O3" "-d1" "-strict-types"
     44      "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings"))
    3945  (extension streams.primitive
    4046    (types-file)
     
    4753    (types-file)
    4854    (component-dependencies streams)
    49     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     55    (csc-options "-O3" "-d1" "-strict-types"
     56      "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings"))
    5057  (extension streams.math
    5158    (types-file)
    5259    (component-dependencies streams streams.utils)
    53     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     60    (csc-options "-O3" "-d1" "-strict-types"
     61      "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings"))
    5462  (extension streams.queue
    5563    (types-file)
    5664    (component-dependencies streams)
    57     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings")) ) )
     65    (csc-options "-O3" "-d1" "-strict-types"
     66      "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings")) ) )
  • release/5/srfi-41/trunk/srfi-41.scm

    r39706 r39998  
    1 ;;;; srfi-41.scm
     1;;;; srfi-41.scm  -*- Scheme -*-
    22;;;; Kon Lovett, Feb '19
    33;;;; Kon Lovett, Apr '09
  • release/5/srfi-41/trunk/streams-derived.scm

    r39989 r39998  
    1 ;;;; streams-derived.scm
     1;;;; streams-derived.scm  -*- Scheme -*-
    22
    3 (declare
    4   (bound-to-procedure ##sys#signal-hook))
     3(module streams-derived ()
    54
    6 (module streams-derived
     5(import scheme (chicken module))
    76
    8 (;export
    9   ; srfi-41 derived
    10   define-stream
    11   stream
    12   stream-let
    13   stream-match
    14   stream-of
    15   stream-constant
    16   list->stream
    17   stream->list
    18   port->stream
    19   stream-length
    20   stream-ref
    21   stream-append
    22   stream-concat
    23   stream-reverse
    24   stream-drop
    25   stream-drop-while
    26   stream-take
    27   stream-take-while
    28   stream-filter
    29   stream-scan
    30   stream-fold
    31   stream-for-each
    32   stream-map
    33   stream-unfold
    34   stream-unfolds
    35   stream-from
    36   stream-iterate
    37   stream-range
    38   stream-zip
    39   ;explicit export: compiler cannot follow syntax >-> syntax
    40   stream-match-test
    41   stream-match-pattern)
    42 
    43 (import scheme
    44   (chicken base)
    45   (chicken fixnum)
    46   (chicken syntax)
    47   (srfi 9)
    48   (srfi 23)
    49   (only (srfi-1) any)
    50   (only type-checks
    51     check-number check-procedure
    52     check-natural-integer
    53     check-input-port check-list)
    54   streams-primitive)
    55 
    56 (include-relative "streams-derived.incl")
     7(import (streams derived))
     8(reexport (streams derived))
    579
    5810) ;module streams-derived
  • release/5/srfi-41/trunk/streams-math.scm

    r39989 r39998  
    1 ;;;; streams-math.scm
    2 
     1;;;; streams-math.scm  -*- Scheme -*-
    32
    43;;;
    54
    6 (module streams-math
     5(module streams-math ()
    76
    8 (;export
    9   prime-number?
    10   stream-max
    11   stream-min
    12   stream-sum
    13   odd-numbers-stream
    14   even-numbers-stream
    15   cardinal-numbers-stream
    16   natural-numbers-stream
    17   prime-numbers-stream
    18   hamming-sequence-stream
    19   fibonacci-stream)
     7(import scheme (chicken module))
    208
    21 (import scheme
    22   (chicken base)
    23   (chicken type)
    24   (chicken syntax)
    25   streams
    26   streams-utils)
    27 
    28 (include-relative "streams-math.incl")
     9(import (streams math))
     10(reexport (streams math))
    2911
    3012) ;module streams-math
  • release/5/srfi-41/trunk/streams-primitive.scm

    r39989 r39998  
    11;;;; streams-primitive.scm  -*- Scheme -*-
    22
    3 (module streams-primitive
     3(module streams-primitive ()
    44
    5 (;export
    6   ;srfi-41 primitive
    7   stream?
    8   stream-null
    9   stream-null?
    10   stream-cons
    11   stream-pair?
    12   stream-car
    13   stream-cdr
    14   stream-lambda
    15   ;extras
    16   stream-occupied?
    17   check-stream
    18   error-stream
    19   check-stream-occupied
    20   error-stream-occupied
    21   ;explicit export: compiler cannot follow syntax >-> syntax
    22   $stream-lazy$
    23   $stream-eager$
    24   $stream-delay$
    25   $make-stream-lazy$
    26   $make-stream-eager$
    27   $make-stream-pair$)
     5(import scheme (chicken module))
    286
    29 (import scheme
    30   (chicken base)
    31   (chicken syntax)
    32   type-checks
    33   type-errors
    34   record-variants)
    35 
    36 (include-relative "streams-primitive.incl")
     7(import (streams primitive))
     8(reexport (streams primitive))
    379
    3810) ;module streams-primitive
  • release/5/srfi-41/trunk/streams-queue.scm

    r39989 r39998  
    11;;;; streams-queue.scm  -*- Scheme -*-
    22
    3 (module streams-queue
     3(module streams-queue ()
    44
    5 (;export
    6   ;original
    7   queue-null
    8   queue-null?
    9   queue-cons
    10   queue-head
    11   queue-tail
    12   ;extras
    13   make-queue
    14   queue)
     5(import scheme (chicken module))
    156
    16 (import scheme
    17   (chicken base)
    18   (chicken fixnum)
    19   (chicken type)
    20   (chicken syntax)
    21   (only type-checks check-pair)
    22   streams)
    23 
    24 (include-relative "streams-queue.incl")
     7(import (streams queue))
     8(reexport (streams queue))
    259
    2610) ;streams-queue
  • release/5/srfi-41/trunk/streams-utils.scm

    r39989 r39998  
    1 ;;;; streams-utils.scm
     1;;;; streams-utils.scm  -*- Scheme -*-
    22
    3 (module streams-utils
     3(module streams-utils ()
    44
    5 (;export
    6   stream-intersperse
    7   stream-permutations
    8   file->stream
    9   stream-split
    10   stream-unique
    11   stream-fold-one
    12   stream-member
    13   stream-merge
    14   stream-partition
    15   stream-finds
    16   stream-find
    17   stream-remove
    18   stream-every
    19   stream-any
    20   stream-and
    21   stream-or
    22   stream-fold-right
    23   stream-fold-right-one
    24   stream-assoc
    25   stream-equal?
    26   stream-quick-sort
    27   stream-insertion-sort
    28   stream-merge-sort
    29   stream-maximum
    30   stream-minimum
    31   binary-tree-same-fringe?)
     5(import scheme (chicken module))
    326
    33 (import scheme
    34   (chicken base)
    35   (chicken type)
    36   (chicken syntax)
    37   (only type-checks
    38     check-list check-procedure
    39     check-string check-natural-integer)
    40   streams)
    41 
    42 (include-relative "streams-utils.incl")
     7(import (streams utils))
     8(reexport (streams utils))
    439
    4410) ;module streams-utils
  • release/5/srfi-41/trunk/streams.derived.scm

    r39989 r39998  
    1 ;;;; streams.derived.scm
     1;;;; streams.derived.scm  -*- Scheme -*-
     2
     3; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA.  All rights
     4; reserved.  Permission is hereby granted, free of charge, to any person obtaining a copy of
     5; this software and associated documentation files (the "Software"), to deal in the Software
     6; without restriction, including without limitation the rights to use, copy, modify, merge,
     7; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
     8; whom the Software is furnished to do so, subject to the following conditions: The above
     9; copyright notice and this permission notice shall be included in all copies or substantial
     10; portions of the Software.  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     11; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
     12; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     13; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
     14; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
     15; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    216
    317(declare
     
    721
    822(;export
    9   ; srfi-41 derived
     23  ;srfi-41 derived
    1024  define-stream
    1125  stream
     
    5468  (streams primitive))
    5569
    56 (include-relative "streams-derived.incl")
     70;;;
     71
     72(define-inline (%check-streams loc strms #!optional argnam)
     73  (when (null? strms) (error loc "no stream arguments" strms))
     74  (for-each (cut check-stream loc <> argnam) strms)
     75  strms )
     76
     77;;fx-inlines.scm
     78
     79(define (fxzero? n) (fx= 0 n))
     80(define (fxadd1 n) (fx+ n 1))
     81(define (fxsub1 n) (fx- n 1))
     82
     83;;;
     84
     85(define-syntax define-stream
     86  (syntax-rules ()
     87    ((define-stream (?name . ?formals) ?body0 ?body1 ...)
     88      (define ?name (stream-lambda ?formals ?body0 ?body1 ...)) ) ) )
     89
     90(define-syntax stream
     91  (syntax-rules ()
     92    ((stream)         stream-null)
     93    ((stream X Y ...) (stream-cons X (stream Y ...)) ) ) )
     94
     95(define-syntax stream-let
     96  (syntax-rules ()
     97    ((stream-let ?tag ((?name ?val) ...) ?body0 ?body1 ...)
     98      ((letrec ((?tag (stream-lambda (?name ...) ?body0 ?body1 ...))) ?tag) ?val ...) ) ) )
     99
     100;FIXME - this forces use of `_' identifier
     101(define-syntax stream-match-pattern
     102  (syntax-rules (_)
     103    ;
     104    ((stream-match-pattern ?strm () (?binding ...) ?body)
     105     (and (stream-null? ?strm)
     106          (let (?binding ...) ?body)) )
     107    ;
     108    ((stream-match-pattern ?strm (_ . ?rest) (?binding ...) ?body)
     109     (and (stream-pair? ?strm)
     110          (let ((strm (stream-cdr ?strm)))
     111            (stream-match-pattern strm ?rest (?binding ...) ?body))) )
     112    ;
     113    ((stream-match-pattern ?strm (?var . ?rest) (?binding ...) ?body)
     114     (and (stream-pair? ?strm)
     115          (let ((temp (stream-car ?strm))
     116                (strm (stream-cdr ?strm)))
     117            (stream-match-pattern strm ?rest ((?var temp) ?binding ...) ?body))) )
     118    ;
     119    ((stream-match-pattern ?strm _ (?binding ...) ?body)
     120     (let (?binding ...) ?body) )
     121    ;
     122    ((stream-match-pattern ?strm ?var (?binding ...) ?body)
     123     (let ((?var ?strm) ?binding ...) ?body) ) ) )
     124
     125(define-syntax stream-match-test
     126  (syntax-rules ()
     127    ;
     128    ((stream-match-test ?strm (?pattern ?fender ?expr))
     129     (stream-match-pattern ?strm ?pattern () (and ?fender (list ?expr))) )
     130    ;
     131    ((stream-match-test ?strm (?pattern ?expr))
     132     (stream-match-pattern ?strm ?pattern () (list ?expr)) ) ) )
     133
     134(define-syntax stream-match
     135  (syntax-rules ()
     136    ((stream-match ?strm-expr ?clause ...)
     137      (let ((strm ?strm-expr))
     138        (cond
     139          ((not (stream? strm))
     140            (error-stream 'stream-match strm 'stream))
     141          ((stream-match-test strm ?clause) => car)
     142          ...
     143          (else
     144            (error 'stream-match "no matching pattern")))) ) ) )
     145
     146(define-syntax stream-of
     147  (syntax-rules (is in)
     148    ;
     149    ((stream-of "aux" ?expr ?base)
     150     (stream-cons ?expr ?base) )
     151    ;
     152    ((stream-of "aux" ?expr ?base (?var in ?strm) ?rest ...)
     153     (stream-let loop ((strm ?strm))
     154       (if (stream-null? strm) ?base
     155           (let ((?var (stream-car strm)))
     156             (stream-of "aux" ?expr (loop (stream-cdr strm)) ?rest ...)))) )
     157    ;
     158    ((stream-of "aux" ?expr ?base (?var is ?exp) ?rest ...)
     159     (let ((?var ?exp)) (stream-of "aux" ?expr ?base ?rest ...)) )
     160    ;
     161    ((stream-of "aux" ?expr ?base ?pred? ?rest ...)
     162     (if ?pred? (stream-of "aux" ?expr ?base ?rest ...) ?base) )
     163    ;
     164    ((stream-of ?expr ?rest ...)
     165     (stream-of "aux" ?expr stream-null ?rest ...) ) ) )
     166
     167;;
     168
     169(define stream-constant
     170  (stream-lambda objs
     171    (cond
     172      ((null? objs)
     173        stream-null )
     174      ((null? (cdr objs))
     175        (stream-cons (car objs) (stream-constant (car objs))) )
     176      (else
     177        (stream-cons
     178          (car objs)
     179          (apply stream-constant (append (cdr objs) (list (car objs))))) ) ) ) )
     180
     181(define (list->stream objects)
     182  ;
     183  (define-stream (list->stream$ objs)
     184    (if (null? objs) stream-null
     185      (stream-cons (car objs) (list->stream$ (cdr objs))) ) )
     186  ;
     187  (list->stream$ (check-list 'list->stream objects 'objects)) )
     188
     189(define (stream->list . args)
     190  (let* ((count (and (fx< 1 (length args))
     191                     (check-natural-integer 'stream->list (car args) 'count)))
     192         (strm (if count (cadr args) (car args)))
     193         (count (or count -1)) )
     194    (let loop ((n count) (strm (check-stream 'stream->list strm 'stream)))
     195      (if (or (fxzero? n) (stream-null? strm)) '()
     196        (cons (stream-car strm) (loop (fxsub1 n) (stream-cdr strm))) ) ) ) )
     197
     198(define (port->stream . port)
     199  ;
     200  (define-stream (port->stream$ p)
     201    (let ((c (read-char p)))
     202      (if (eof-object? c) stream-null
     203        (stream-cons c (port->stream$ p)) ) )  )
     204  ;
     205  (let ((port (if (null? port) (current-input-port) (car port))))
     206    (port->stream$ (check-input-port 'port->stream port 'port))) )
     207
     208(define (stream-length strm)
     209  (let loop ((len 0) (strm (check-stream 'stream-length strm 'stream)))
     210    (if (stream-null? strm) len
     211      (loop (fxadd1 len) (stream-cdr strm)) ) ) )
     212
     213(define (stream-ref strm index)
     214  (let loop ((strm (check-stream 'stream-ref strm 'stream))
     215             (n (check-natural-integer 'stream-ref index 'index)))
     216    (cond
     217      ((stream-null? strm)
     218        (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) )
     219      ((fxzero? n)
     220        (stream-car strm) )
     221      (else
     222        (loop (stream-cdr strm) (fxsub1 n)) ) ) ) )
     223
     224(define (stream-reverse strm)
     225  ;
     226  (define-stream (stream-reverse$ strm rev)
     227    (if (stream-null? strm) rev
     228      (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )
     229  ;
     230  (stream-reverse$ (check-stream 'stream-reverse strm 'stream) stream-null) )
     231
     232(define (stream-append . strms)
     233  ;
     234  (define-stream (stream-append$ strms)
     235    (cond
     236      ((null? (cdr strms))
     237        (car strms) )
     238      ((stream-null? (car strms))
     239        (stream-append$ (cdr strms)) )
     240      (else
     241        (stream-cons
     242          (stream-car (car strms))
     243          (stream-append$ (cons (stream-cdr (car strms)) (cdr strms)))) ) ) )
     244  ;
     245  (if (null? strms) stream-null
     246    (stream-append$ (%check-streams 'stream-append strms 'stream)) ) )
     247
     248(define (stream-concat strm)
     249  ;
     250  (define-stream (stream-concat$ strm)
     251    (cond
     252      ((stream-null? strm)
     253        stream-null )
     254      ((not (stream? (stream-car strm)))
     255        (error-stream 'stream-concat strm) )
     256      ((stream-null? (stream-car strm))
     257        (stream-concat$ (stream-cdr strm)) )
     258      (else
     259        (stream-cons
     260          (stream-car (stream-car strm))
     261          (stream-concat$
     262            (stream-cons
     263              (stream-cdr (stream-car strm))
     264              (stream-cdr strm)))) ) ) )
     265  ;
     266  (stream-concat$ (check-stream 'stream-concat strm 'stream)) )
     267
     268(define (stream-drop count strm)
     269  ;
     270  (define-stream (stream-drop$ n strm)
     271    (if (or (fxzero? n) (stream-null? strm)) strm
     272      (stream-drop$ (fxsub1 n) (stream-cdr strm)) ) )
     273  ;
     274  (stream-drop$
     275    (check-natural-integer 'stream-drop count 'count)
     276    (check-stream 'stream-drop strm 'stream)) )
     277
     278(define (stream-drop-while predicate? strm)
     279  ;
     280  (define-stream (stream-drop-while$ strm)
     281    (if (not (and (stream-pair? strm) (predicate? (stream-car strm)))) strm
     282      (stream-drop-while$ (stream-cdr strm)) ) )
     283  ;
     284  (check-procedure 'stream-drop-while predicate? 'predicate?)
     285  (stream-drop-while$ (check-stream 'stream-drop-while strm 'stream)) )
     286
     287(define (stream-take count strm)
     288  ;
     289  (define-stream (stream-take$ n strm)
     290    (if (or (stream-null? strm) (fxzero? n)) stream-null
     291      (stream-cons
     292        (stream-car strm)
     293        (stream-take$ (fxsub1 n) (stream-cdr strm))) ) )
     294  ;
     295  (stream-take$
     296    (check-natural-integer 'stream-take count 'count)
     297    (check-stream 'stream-take strm 'stream)) )
     298
     299(define (stream-take-while predicate? strm)
     300  ;
     301 (define-stream (stream-take-while$ strm)
     302    (cond
     303      ((stream-null? strm)
     304        stream-null )
     305      ((predicate? (stream-car strm))
     306        (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))) )
     307      (else
     308        stream-null ) ) )
     309  ;
     310  (check-procedure 'stream-take-while predicate? 'predicate?)
     311  (stream-take-while$ (check-stream 'stream-take-while strm 'stream)) )
     312
     313(define (stream-filter predicate? strm)
     314  ;
     315  (define-stream (stream-filter$ strm)
     316    (cond
     317      ((stream-null? strm)
     318        stream-null )
     319      ((predicate? (stream-car strm))
     320        (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))) )
     321      (else
     322        (stream-filter$ (stream-cdr strm)) ) ) )
     323  ;
     324  (check-procedure 'stream-filter predicate? 'predicate?)
     325  (stream-filter$ (check-stream 'stream-filter strm 'stream)) )
     326
     327(define (stream-scan function base strm)
     328  ;
     329  (define-stream (stream-scan$ base strm)
     330    (if (stream-null? strm) (stream base)
     331      (stream-cons
     332        base
     333        (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) )
     334  ;
     335  (check-procedure 'stream-scan function 'function)
     336  (stream-scan$ base (check-stream 'stream-scan strm 'stream)) )
     337
     338(define (stream-fold function base . strms)
     339  ;
     340  (define (stream-folder base strms)
     341    (if (any stream-null? strms) base
     342      (stream-folder
     343        (apply function base (map stream-car strms))
     344        (map stream-cdr strms)) ) )
     345  ;
     346  (check-procedure 'stream-fold function 'function)
     347  (stream-folder base (%check-streams 'stream-fold strms 'stream)) )
     348
     349(define (stream-for-each procedure . strms)
     350  ;
     351  (define (stream-for-eacher strms)
     352    (unless (any stream-null? strms)
     353      (apply procedure (map stream-car strms))
     354      (stream-for-eacher (map stream-cdr strms)) ) )
     355  ;
     356  (check-procedure 'stream-for-each procedure 'procedure)
     357  (stream-for-eacher (%check-streams 'stream-for-each strms 'stream)) )
     358
     359(define (stream-map function . strms)
     360  ;
     361  ; not tail-recursive to avoid `stream-reverse'
     362  (define-stream (stream-map$ strms)
     363    (if (any stream-null? strms) stream-null
     364      (stream-cons
     365        (apply function (map stream-car strms))
     366        (stream-map$ (map stream-cdr strms))) ) )
     367  ;
     368  (check-procedure 'stream-map function 'function)
     369  (stream-map$ (%check-streams 'stream-map strms 'stream)) )
     370
     371(define (stream-from first . step)
     372  ;
     373  (define-stream (stream-from$ first delta)
     374    (stream-cons first (stream-from$ (fx+ first delta) delta)) )
     375  ;
     376  (let ((delta (if (null? step) 1 (car step))))
     377    (stream-from$
     378      (check-number 'stream-from first 'first)
     379      (check-number 'stream-from delta 'delta)) ) )
     380
     381(define (stream-iterate function base)
     382  ;
     383  (define-stream (stream-iterate$ base)
     384    (stream-cons base (stream-iterate$ (function base))) )
     385  ;
     386  (check-procedure 'stream-iterate function 'function)
     387  (stream-iterate$ base) )
     388
     389(define (stream-range first past . step)
     390  ;
     391  (define-stream (stream-range$ first past delta lt?)
     392    (if (not (lt? first past)) stream-null
     393      (stream-cons first (stream-range$ (fx+ first delta) past delta lt?)) ) )
     394  ;
     395  (check-number 'stream-range first 'first)
     396  (check-number 'stream-range past 'past)
     397  (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
     398    (check-number 'stream-range delta 'delta)
     399    (let ((lt? (if (< 0 delta) < >)))
     400      (stream-range$ first past delta lt?) ) ) )
     401
     402(define (stream-unfold mapper predicate? generator base)
     403  ;
     404  (define-stream (stream-unfold$ base)
     405    (if (not (predicate? base)) stream-null
     406      (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )
     407  ;
     408  (check-procedure 'stream-unfold mapper 'mapper)
     409  (check-procedure 'stream-unfold predicate? 'predicate?)
     410  (check-procedure 'stream-unfold generator 'generator)
     411  (stream-unfold$ base) )
     412
     413(define (stream-unfolds generator seed)
     414  ;
     415  (define (len-values)
     416    (call-with-values
     417      (lambda () (generator seed))
     418      (lambda vs (fxsub1 (length vs)))) )
     419  ;
     420  (define-stream (unfold-result-stream seed)
     421    (call-with-values
     422      (lambda () (generator seed))
     423      (lambda (next . results)
     424        (stream-cons results (unfold-result-stream next)))) )
     425  ;
     426  (define-stream (result-stream->output-stream result-stream i)
     427    (let ((result (list-ref (stream-car result-stream) (fxsub1 i))))
     428      (cond
     429        ((pair? result)
     430          (stream-cons
     431            (car result)
     432            (result-stream->output-stream (stream-cdr result-stream) i)) )
     433        ((not result)
     434          (result-stream->output-stream (stream-cdr result-stream) i) )
     435        ((null? result)
     436          stream-null )
     437        (else
     438          (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) )
     439  ;
     440  (define (result-stream->output-strms result-stream)
     441    (let loop ((i (len-values)) (outputs '()))
     442      (if (fxzero? i) (apply values outputs)
     443        (loop (fxsub1 i) (cons (result-stream->output-stream result-stream i) outputs)) ) ) )
     444  ;
     445  (check-procedure 'stream-unfolds generator 'generator)
     446  (result-stream->output-strms (unfold-result-stream seed)) )
     447
     448(define (stream-zip . strms)
     449  ;
     450  (define-stream (stream-zip$ strms)
     451    (if (any stream-null? strms) stream-null
     452      (stream-cons
     453        (map stream-car strms)
     454        (stream-zip$ (map stream-cdr strms))) ) )
     455  ;
     456  (stream-zip$ (%check-streams 'stream-zip strms 'stream)) )
    57457
    58458) ;module (streams derived)
  • release/5/srfi-41/trunk/streams.math.scm

    r39989 r39998  
    1 ;;;; streams.math.scm
     1;;;; streams.math.scm  -*- Scheme -*-
    22
    3 ;;;
     3; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA.  All rights
     4; reserved.  Permission is hereby granted, free of charge, to any person obtaining a copy of
     5; this software and associated documentation files (the "Software"), to deal in the Software
     6; without restriction, including without limitation the rights to use, copy, modify, merge,
     7; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
     8; whom the Software is furnished to do so, subject to the following conditions: The above
     9; copyright notice and this permission notice shall be included in all copies or substantial
     10; portions of the Software.  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     11; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
     12; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     13; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
     14; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
     15; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    416
    517(module (streams math)
     
    2537  (streams utils))
    2638
    27 (include-relative "streams-math.incl")
     39;;; Section Combinators
     40
     41(define (left-section fn . args) (lambda xs (apply fn (append args xs))))
     42
     43;;;
     44
     45(define (stream-max strm)
     46  (stream-fold-one max (check-stream 'stream-max strm 'stream)) )
     47
     48(define (stream-min strm)
     49  (stream-fold-one min (check-stream 'stream-min strm 'stream)) )
     50
     51(define stream-sum (left-section stream-fold + 0))
     52
     53(define odd-numbers-stream (stream-from 1 2))
     54
     55(define even-numbers-stream (stream-from 0 2))
     56
     57(define cardinal-numbers-stream (stream-iterate add1 0))
     58
     59(define natural-numbers-stream (stream-iterate add1 1))
     60
     61#|
     62(define-stream (prime-sieve$ strm)
     63  (define-stream (sift$ base strm)
     64    (define-stream (next$ base mult strm)
     65      (let ((first (stream-car strm))
     66            (rest (stream-cdr strm)))
     67        (cond
     68          ((< first mult)
     69            (stream-cons first (next$ base mult rest)) )
     70          ((< mult first)
     71            (next$ base (+ base mult) strm) )
     72          (else
     73            (next$ base (+ base mult) rest) ) ) ) )
     74    (next$ base (+ base base) strm) )
     75  (let ((first (stream-car strm))
     76        (rest (stream-cdr strm)))
     77    (stream-cons first (prime-sieve$ (sift$ first rest))) ) )
     78
     79(define prime-numbers-stream (prime-sieve$ (stream-from 2)))
     80|#
     81
     82(define prime-numbers-stream
     83  (stream-cons 2 (stream-filter prime-number? (stream-drop 2 natural-numbers-stream))) )
     84
     85(define (prime-number? n)
     86  ;
     87  (define (iter s)
     88    (let (
     89      (np (stream-car s)) )
     90      (cond
     91        ((> np (sqrt n))      #t)
     92        ((= 0 (modulo n np))  #f)
     93        (else                 (iter (stream-cdr s)) ) ) ) )
     94  ;
     95  (iter prime-numbers-stream) )
     96
     97;; http://www.research.att.com/~njas/sequences/A051037
     98
     99(define hamming-sequence-stream
     100  (stream-cons 1
     101    (stream-unique =
     102      (stream-merge <
     103        (stream-map (left-section * 2) hamming-sequence-stream)
     104        (stream-map (left-section * 3) hamming-sequence-stream)
     105        (stream-map (left-section * 5) hamming-sequence-stream)))) )
     106
     107#;
     108(define power-table
     109  (stream-of
     110    (stream-of (expt m n) (m in (stream-from 1)))
     111    (n in (stream-from 2))))
     112
     113(define fibonacci-stream
     114  (stream-cons 0
     115    (stream-cons 1
     116      (stream-map +
     117        fibonacci-stream
     118        (stream-cdr fibonacci-stream)))))
    28119
    29120) ;module (streams math)
  • release/5/srfi-41/trunk/streams.primitive.scm

    r39989 r39998  
    11;;;; streams.primitive.scm  -*- Scheme -*-
     2
     3; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA.  All rights
     4; reserved.  Permission is hereby granted, free of charge, to any person obtaining a copy of
     5; this software and associated documentation files (the "Software"), to deal in the Software
     6; without restriction, including without limitation the rights to use, copy, modify, merge,
     7; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
     8; whom the Software is furnished to do so, subject to the following conditions: The above
     9; copyright notice and this permission notice shall be included in all copies or substantial
     10; portions of the Software.  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     11; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
     12; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     13; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
     14; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
     15; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    216
    317(module (streams primitive)
     
    3448  record-variants)
    3549
    36 (include-relative "streams-primitive.incl")
     50;;;
     51
     52;; ensure identifier defined
     53(define stream 'stream)
     54(define-record-type-variant stream (unsafe unchecked inline)
     55  (%make-stream prom)
     56  (%stream?)
     57  (prom %stream-promise %stream-promise-set!) )
     58
     59(define-inline (stream-tagged-pair? obj)
     60  (and
     61    (pair? obj)
     62    (let ((tag (car obj)))
     63      (or (eq? 'lazy tag) (eq? 'eager tag)) ) ) )
     64
     65(define-inline (make-stream-box tag obj) (cons tag obj))
     66(define-inline (stream-box-tag box) (car box))
     67(define-inline (stream-box-value box) (cdr box))
     68(define-inline (stream-box-tag-set! box tag) (set-car! box tag))
     69(define-inline (stream-box-value-set! box val) (set-cdr! box val))
     70
     71(define-inline (make-stream-lazy-box obj) (make-stream-box 'lazy obj))
     72(define-inline (make-stream-eager-box obj) (make-stream-box 'eager obj))
     73
     74(define-inline (stream-lazy-box? obj) (eq? 'lazy (stream-box-tag obj)))
     75(define-inline (stream-eager-box? obj) (eq? 'eager (stream-box-tag obj)))
     76
     77(define-inline (check-stream-box loc obj)
     78  (unless (stream-tagged-pair? obj)
     79    (error-argument-type loc obj "stream-box") )
     80  obj )
     81
     82(define (stream-print obj out)
     83  (display "#<" out)
     84  (let ((promise (%stream-promise obj)))
     85    (cond
     86      ((stream-eager-box? promise)  (display "eager stream" out))
     87      ((stream-lazy-box? promise)   (display "lazy stream" out))
     88      (else
     89        (display "unknown stream " out) (display promise out)) ) )
     90  (display ">" out) )
     91
     92;;;
     93
     94(define ($make-stream-lazy$ thunk) (%make-stream (make-stream-lazy-box thunk)))
     95(define ($make-stream-eager$ obj) (%make-stream (make-stream-eager-box obj)))
     96
     97(define-syntax $stream-lazy$
     98  (syntax-rules ()
     99    (($stream-lazy$ ?expr)
     100      ($make-stream-lazy$ (lambda () ?expr)) ) ) )
     101
     102(define-syntax $stream-eager$
     103  (syntax-rules ()
     104    (($stream-eager$ ?expr)
     105      ($make-stream-eager$ ?expr) ) ) )
     106
     107(define-syntax $stream-delay$
     108  (syntax-rules ()
     109    (($stream-delay$ ?expr)
     110      ($stream-lazy$ ($stream-eager$ ?expr)) ) ) )
     111
     112;;;
     113
     114(define (stream? obj) (%stream? obj))
     115
     116(define-check+error-type stream)
     117
     118(define (stream-force prom)
     119  (let* (
     120    (content (%stream-promise (check-stream #f prom)))
     121    (promise-box-value (stream-box-value content)) )
     122    ;better be there! (check-stream-box #f content)
     123    (case (stream-box-tag content)
     124      ((eager)
     125        promise-box-value )
     126      ((lazy)
     127        (let* (
     128          (prom* (promise-box-value))
     129          ;re-fetch promise in case changed by recursion via above call.
     130          (content (%stream-promise prom)) )
     131          ;re-establish bona-fides
     132          (check-stream #f prom*)
     133          ;better be there! (check-stream-box #f content)
     134          (unless (eq? 'eager (stream-box-tag content))
     135            (let ((content* (%stream-promise prom*)))
     136              (stream-box-tag-set! content (stream-box-tag content*))
     137              (stream-box-value-set! content (stream-box-value content*)) )
     138            (%stream-promise-set! prom* content) )
     139          (stream-force prom) ) ) ) ) )
     140
     141(define stream-null ($stream-delay$ (cons 'stream 'null)))
     142
     143(define-inline (*stream-null? strm)
     144  (eq? (stream-force strm) (stream-force stream-null)) )
     145
     146(define (stream-null? obj) (and (%stream? obj) (*stream-null? obj)))
     147(define (stream-occupied? obj) (and (%stream? obj) (not (*stream-null? obj))))
     148
     149(define-check+error-type stream-occupied)
     150
     151(define-syntax stream-lambda
     152  (syntax-rules ()
     153    ((stream-lambda ?formals ?body0 ?body1 ...)
     154     (lambda ?formals ($stream-lazy$ (let () ?body0 ?body1 ...))) ) ) )
     155
     156;;
     157
     158;; ensure identifier defined
     159(define stream-pair 'stream-pair)
     160(define-record-type-variant stream-pair (unsafe unchecked inline)
     161  (%make-stream-pair hd tl)
     162  (%stream-pair?)
     163  (hd %stream-car)
     164  (tl %stream-cdr) )
     165
     166;want inline car/cdr but need exportable procedure for make.
     167(define ($make-stream-pair$ hd tl) (%make-stream-pair hd tl))
     168
     169(define-error-type stream-pair)
     170
     171(define-inline (checked-stream-pair loc obj)
     172  (cond
     173    ((not (%stream? obj))
     174      (error-stream loc obj 'stream) )
     175    ((*stream-null? obj)
     176      (error-stream-occupied loc obj 'stream) )
     177    (else
     178      (let ((val (stream-force obj)))
     179        (if (%stream-pair? val)
     180          val
     181          (error-stream-pair loc val 'stream)) ) ) ) )
     182
     183(define (stream-pair-print obj out)
     184  (display "#<" out)
     185  (display (%stream-car obj) out)
     186  (display " " out)
     187  (display (%stream-cdr obj) out)
     188  (display ">" out) )
     189
     190(define-syntax stream-cons
     191  (syntax-rules ()
     192    ((_ ?expr ?strm)
     193      ($stream-eager$ ($make-stream-pair$ ($stream-delay$ ?expr) ($stream-lazy$ ?strm))) ) ) )
     194
     195(define (stream-pair? obj)
     196  (and (%stream? obj) (%stream-pair? (stream-force obj))) )
     197
     198(define (stream-car strm)
     199  (stream-force (%stream-car (checked-stream-pair 'stream-car strm))) )
     200
     201(define (stream-cdr strm)
     202  (%stream-cdr (checked-stream-pair 'stream-cdr strm)) )
     203
     204;;;
     205
     206(set! (record-printer stream) stream-print)
     207
     208(set! (record-printer stream-pair) stream-pair-print)
    37209
    38210) ;module (streams primitive)
  • release/5/srfi-41/trunk/streams.queue.scm

    r39989 r39998  
    2727  streams)
    2828
    29 (include-relative "streams-queue.incl")
     29;;;
     30
     31(define (finalize-queue f r)
     32  (if (fx< (stream-length r) (stream-length f))
     33    (cons f r)
     34    (cons (stream-append f (stream-reverse r)) stream-null) ) )
     35
     36;;;
     37
     38(define queue-null
     39  (cons stream-null stream-null) )
     40
     41(define (queue-null? x)
     42  (and (pair? x) (stream-null (car x))) )
     43
     44(define (queue-cons q x)
     45  (check-pair 'queue-cons q 'queue)
     46  (finalize-queue (car q) (stream-cons x (cdr q))) )
     47
     48(define (queue-head q)
     49  (check-pair 'queue-head q 'queue)
     50  (if (stream-null? (car q))
     51    (error 'queue-head "empty queue")
     52    (stream-car (car q)) ) )
     53
     54(define (queue-tail q)
     55  (check-pair 'queue-tail q 'queue)
     56  (if (stream-null? (car q))
     57    (error 'queue-tail "empty queue")
     58    (finalize-queue (stream-cdr (car q)) (cdr q)) ) )
     59
     60;;
     61
     62; l 1 2 3 => q 3 2 1
     63(define (make-queue ls)
     64  (let loop ((ls ls) (q queue-null))
     65    (if (null? ls) q
     66      (loop (cdr ls) (queue-cons q (car ls))) ) ) )
     67
     68; 1 2 3 => q 3 2 1
     69(define (queue . rest) (apply make-queue rest))
    3070
    3171) ;(streams queue)
  • release/5/srfi-41/trunk/streams.scm

    r39989 r39998  
    1 ;;;; streams.scm
     1;;;; streams.scm  -*- Scheme -*-
    22;;;; Kon Lovett, Feb '19
    33;;;; Kon Lovett, Apr '09
  • release/5/srfi-41/trunk/streams.utils.scm

    r39989 r39998  
    1 ;;;; streams.utils.scm
     1;;;; streams.utils.scm  -*- Scheme -*-
     2
     3; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA.  All rights
     4; reserved.  Permission is hereby granted, free of charge, to any person obtaining a copy of
     5; this software and associated documentation files (the "Software"), to deal in the Software
     6; without restriction, including without limitation the rights to use, copy, modify, merge,
     7; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
     8; whom the Software is furnished to do so, subject to the following conditions: The above
     9; copyright notice and this permission notice shall be included in all copies or substantial
     10; portions of the Software.  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     11; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
     12; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     13; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
     14; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
     15; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    216
    317(module (streams utils)
     
    4054  streams)
    4155
    42 (include-relative "streams-utils.incl")
     56;;;
     57
     58(define-inline (%check-streams loc strms #!optional argnam)
     59  (when (null? strms) (error loc "no stream arguments" strms))
     60  (for-each (cut check-stream loc <> argnam) strms)
     61  strms )
     62
     63;(append xs args) = (reverse (append (reverse args) (reverse xs)))
     64(define (right-section fn . args) (lambda xs (apply fn (append xs args))))
     65
     66;;;
     67
     68(define-stream (stream-intersperse yy x)
     69  (stream-match (check-stream 'stream-intersperse yy 'stream)
     70    (()
     71      (stream (stream x)) )
     72    ((y . ys)
     73      (stream-append
     74        (stream (stream-cons x yy))
     75        (stream-map (lambda (z) (stream-cons y z)) (stream-intersperse ys x))) ) ) )
     76
     77(define-stream (stream-permutations xs)
     78  (if (stream-null? (check-stream 'stream-permutations xs 'stream))
     79    (stream (stream))
     80    (stream-concat
     81      (stream-map
     82        (right-section stream-intersperse (stream-car xs))
     83        (stream-permutations (stream-cdr xs)))) ) )
     84
     85(define-stream (file->stream filename #!optional (reader read-char))
     86  (check-procedure 'file->streams reader 'reader)
     87  (let ((port (open-input-file (check-string 'file->streams filename 'filename))))
     88    (stream-let loop ((item (reader port)))
     89      (if (eof-object? item)
     90        (begin (close-input-port port) stream-null)
     91        (stream-cons item (loop (reader port))) ) ) ) )
     92
     93(define (stream-split count strm)
     94  (check-stream 'stream-split strm 'stream)
     95  (check-natural-integer 'stream-split count 'count)
     96  (values (stream-take count strm) (stream-drop count strm)))
     97
     98(define-stream (stream-unique eql? strm)
     99  (check-procedure 'stream-unique eql? 'equivalence)
     100  (stream-let loop ((strm (check-stream 'stream-unique strm 'stream)))
     101    (if (stream-null? strm)
     102      stream-null
     103      (stream-cons
     104        (stream-car strm)
     105        (loop (stream-drop-while (lambda (x) (eql? (stream-car strm) x)) strm))) ) ) )
     106
     107(define (stream-fold-one func strm)
     108  (check-stream 'stream-fold-one strm 'stream)
     109  (stream-fold
     110    (check-procedure 'stream-fold-one func 'function)
     111    (stream-car strm)
     112    (stream-cdr strm)) )
     113
     114(define-stream (stream-member eql? item strm)
     115  (check-procedure 'stream-member eql? 'equivalence)
     116  (stream-let loop ((strm (check-stream 'stream-member strm 'stream)))
     117    (cond
     118      ((stream-null? strm)
     119        #f)
     120      ((eql? item (stream-car strm))
     121        strm)
     122      (else
     123        (loop (stream-cdr strm)) ) ) ) )
     124
     125(define-stream (stream-merge lt? . strms)
     126  ;
     127  (define-stream (stream-merge$ xx yy)
     128    (stream-match xx
     129      (()
     130        yy )
     131      ((x . xs)
     132        (stream-match yy
     133          (() xx )
     134          ((y . ys)
     135            (if (lt? y x) (stream-cons y (stream-merge$ xx ys))
     136              (stream-cons x (stream-merge$ xs yy))))) ) ) )
     137  ;
     138  (check-procedure 'stream-merge lt? 'less-than)
     139  (stream-let loop ((strms (%check-streams 'stream-merge strms 'stream)))
     140    (cond
     141      ((null? strms)
     142        stream-null )
     143      ((null? (cdr strms))
     144        (car strms) )
     145      (else
     146        (stream-merge$ (car strms) (apply stream-merge lt? (cdr strms))) ) ) ) )
     147
     148(define (stream-partition pred? strm)
     149  (check-procedure 'stream-partition pred? 'predicate)
     150  (stream-unfolds
     151    (lambda (s)
     152      (if (stream-null? s) (values s '() '())
     153        (let ((a (stream-car s))
     154              (d (stream-cdr s)))
     155          (if (pred? a)
     156            (values d (list a) #f)
     157            (values d #f (list a)) ) ) ) )
     158    (check-stream 'stream-partition strm 'stream)) )
     159
     160(define-stream (stream-finds eql? item strm)
     161  (check-procedure 'stream-finds eql? 'equivalence)
     162  (stream-of
     163    (car x)
     164    (x in (stream-zip (stream-from 0) (check-stream 'stream-finds strm 'stream)))
     165    (eql? item (cadr x))) )
     166
     167(define (stream-find eql? item strm)
     168  (check-stream 'stream-find strm 'stream)
     169  (check-procedure 'stream-find eql? 'equivalence)
     170  (stream-car (stream-append (stream-finds eql? item strm) (stream #f))) )
     171
     172(define-stream (stream-remove pred? strm)
     173  (check-procedure 'stream-remove pred? 'predicate)
     174  (stream-filter (complement pred?) (check-stream 'stream-remove strm 'stream)) )
     175
     176(define (stream-every pred? strm)
     177  (check-procedure 'stream-every pred? 'predicate)
     178  (let loop ((strm (check-stream 'stream-every strm 'stream)))
     179    (cond
     180      ((stream-null? strm)
     181        #t )
     182      ((not (pred? (stream-car strm)))
     183        #f )
     184      (else
     185        (loop (stream-cdr strm)) ) ) ) )
     186
     187(define (stream-any pred? strm)
     188  (check-procedure 'stream-any pred? 'predicate)
     189  (let loop ((strm (check-stream 'stream-any strm 'stream)))
     190    (cond
     191      ((stream-null? strm)
     192        #f )
     193      ((pred? (stream-car strm))
     194        #t )
     195      (else
     196        (loop (stream-cdr strm)) ) ) ) )
     197
     198(define (stream-and strm)
     199  (let loop ((strm (check-stream 'stream-and strm 'stream)))
     200    (cond
     201      ((stream-null? strm)
     202        #t )
     203      ((not (stream-car strm))
     204        #f )
     205      (else
     206        (loop (stream-cdr strm)) ) ) ) )
     207
     208(define (stream-or strm)
     209  (check-stream 'stream-or strm 'stream)
     210  (let loop ((strm strm))
     211    (cond
     212      ((stream-null? strm)
     213        #f )
     214      ((stream-car strm)
     215        #t )
     216      (else
     217        (loop (stream-cdr strm)) ) ) ) )
     218
     219(define (stream-fold-right func base strm)
     220  (check-procedure 'stream-fold-right func 'function)
     221  (let loop ((strm (check-stream 'stream-fold-right strm 'stream)))
     222    (if (stream-null? strm)
     223      base
     224      (func (stream-car strm) (loop (stream-cdr strm))) ) ) )
     225
     226(define (stream-fold-right-one func strm)
     227  (check-procedure 'stream-fold-right-one func 'function)
     228  (let loop ((strm (check-stream 'stream-fold-right-one strm 'stream)))
     229    (stream-match strm
     230      ((x) x )
     231      ((x . xs) (func x (loop xs)) ) ) ) )
     232
     233(define (stream-assoc key dict #!optional (eql? equal?))
     234  (check-procedure 'stream-assoc eql? 'equivalence)
     235  (let loop ((dict (check-stream 'stream-assoc dict 'stream)))
     236    (cond
     237      ((stream-null? dict)
     238        #f )
     239      ((eql? key (car (stream-car dict)))
     240        (stream-car dict) )
     241      (else
     242        (loop (stream-cdr dict)) ) ) ) )
     243
     244; May never return
     245(define (stream-equal? eql? xs ys)
     246  (let loop ((xs (check-stream 'stream-equal? xs 'stream1))
     247             (ys (check-stream 'stream-equal? ys 'stream2)))
     248    (cond
     249      ((and (stream-null? xs) (stream-null? ys))
     250        #t )
     251      ((or (stream-null? xs) (stream-null? ys))
     252        #f )
     253      ((not (eql? (stream-car xs) (stream-car ys)))
     254        #f )
     255      (else
     256        (loop (stream-cdr xs) (stream-cdr ys)) ) ) ) )
     257
     258(define-stream (stream-quick-sort lt? strm)
     259  (check-procedure 'stream-quick-sort lt? 'less-than)
     260  (let loop ((strm (check-stream 'stream-quick-sort strm 'stream)))
     261    (if (stream-null? strm)
     262      stream-null
     263      (let ((x (stream-car strm))
     264            (xs (stream-cdr strm)))
     265        (stream-append
     266          (loop (stream-filter (lambda (u) (lt? u x)) xs))
     267          (stream x)
     268          (loop (stream-filter (lambda (u) (not (lt? u x))) xs))) ) ) ) )
     269
     270(define-stream (stream-insertion-sort lt? strm)
     271  ;
     272  (define-stream (insert$ strm x)
     273    (stream-match strm
     274      (()
     275        (stream x) )
     276      ((y . ys)
     277        (if (lt? y x) (stream-cons y (insert$ ys x))
     278          (stream-cons x strm) ) ) ) )
     279  ;
     280  (check-procedure 'stream-insertion-sort lt? 'less-than)
     281  (stream-fold insert$ stream-null (check-stream 'stream-insertion-sort strm 'stream)) )
     282
     283(define-stream (stream-merge-sort lt? strm)
     284  (check-procedure 'stream-merge-sort lt? 'less-than)
     285  (let loop ((strm (check-stream 'stream-merge-sort strm 'stream)))
     286    (let ((n (quotient (stream-length strm) 2)))
     287      (if (zero? n)
     288        strm
     289        (stream-merge lt? (loop (stream-take n strm)) (loop (stream-drop n strm))) ) ) ) )
     290
     291(define (stream-maximum lt? strm)
     292  (check-procedure 'stream-maximum lt? 'less-than)
     293  (stream-fold-one
     294    (lambda (x y) (if (lt? x y) y x))
     295    (check-stream 'stream-maximum strm 'stream)) )
     296
     297(define (stream-minimum lt? strm)
     298  (check-procedure 'stream-minimum lt? 'less-than)
     299  (stream-fold-one
     300    (lambda (x y) (if (lt? x y) x y))
     301    (check-stream 'stream-minimum strm 'stream)) )
     302
     303;; Lazy binary-tree "same fringe"
     304
     305(define (binary-tree-same-fringe? tree1 tree2 #!optional (eql? equal?))
     306  ;
     307  (define-stream (flatten tree)
     308    (cond
     309      ((null? tree)
     310        stream-null )
     311      ((pair? (car tree) )
     312        (stream-append (flatten (car tree)) (flatten (cdr tree))))
     313      (else
     314        (stream-cons (car tree) (flatten (cdr tree))) ) ) )
     315  ;
     316  (let loop ((t1 (flatten (check-list 'same-fringe? tree1 'tree1)))
     317             (t2 (flatten (check-list 'same-fringe? tree2 'tree2))))
     318    (cond
     319      ((and (stream-null? t1) (stream-null? t2))
     320        #t )
     321      ((or  (stream-null? t1) (stream-null? t2))
     322        #f )
     323      ((not (eql? (stream-car t1) (stream-car t2)))
     324        #f )
     325      (else
     326        (loop (stream-cdr t1) (stream-cdr t2)) ) ) ) )
    43327
    44328) ;module (streams utils)
Note: See TracChangeset for help on using the changeset viewer.