Changeset 39989 in project


Ignore:
Timestamp:
04/13/21 04:25:09 (4 months ago)
Author:
Kon Lovett
Message:

per dieggsy irc "... (streams derived) as the srfi suggests"

Location:
release/5/srfi-41/trunk
Files:
10 added
8 edited

Legend:

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

    r39924 r39989  
    22
    33((synopsis "SRFI 41 (Streams)")
    4  (version "2.0.6")
     4 (version "2.1.0")
    55 (category data)
    66 (author "Philip L. Bewig, for CHICKEN by Kon Lovett")
     
    1616  (extension streams
    1717    (types-file)
    18     (component-dependencies streams-primitive streams-derived)
     18    (component-dependencies streams.primitive streams.derived)
    1919    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
    2020  (extension streams-primitive
     
    3636    (types-file)
    3737    (component-dependencies streams)
     38    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     39  (extension streams.primitive
     40    (types-file)
     41    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
     42  (extension streams.derived
     43    (types-file)
     44    (component-dependencies streams.primitive)
     45    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
     46  (extension streams.utils
     47    (types-file)
     48    (component-dependencies streams)
     49    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     50  (extension streams.math
     51    (types-file)
     52    (component-dependencies streams streams.utils)
     53    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     54  (extension streams.queue
     55    (types-file)
     56    (component-dependencies streams)
    3857    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings")) ) )
  • release/5/srfi-41/trunk/streams-derived.scm

    r39713 r39989  
    11;;;; 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.
    172
    183(declare
     
    6954  streams-primitive)
    7055
    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)) )
     56(include-relative "streams-derived.incl")
    45857
    45958) ;module streams-derived
  • release/5/srfi-41/trunk/streams-math.scm

    r39713 r39989  
    11;;;; streams-math.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.
    172
    183
     
    4126  streams-utils)
    4227
    43 ;;; Section Combinators
    44 
    45 (define (left-section fn . args) (lambda xs (apply fn (append args xs))))
    46 
    47 ;;;
    48 
    49 (define (stream-max strm)
    50   (stream-fold-one max (check-stream 'stream-max strm 'stream)) )
    51 
    52 (define (stream-min strm)
    53   (stream-fold-one min (check-stream 'stream-min strm 'stream)) )
    54 
    55 (define stream-sum (left-section stream-fold + 0))
    56 
    57 (define odd-numbers-stream (stream-from 1 2))
    58 
    59 (define even-numbers-stream (stream-from 0 2))
    60 
    61 (define cardinal-numbers-stream (stream-iterate add1 0))
    62 
    63 (define natural-numbers-stream (stream-iterate add1 1))
    64 
    65 #|
    66 (define-stream (prime-sieve$ strm)
    67   (define-stream (sift$ base strm)
    68     (define-stream (next$ base mult strm)
    69       (let ((first (stream-car strm))
    70             (rest (stream-cdr strm)))
    71         (cond
    72           ((< first mult)
    73             (stream-cons first (next$ base mult rest)) )
    74           ((< mult first)
    75             (next$ base (+ base mult) strm) )
    76           (else
    77             (next$ base (+ base mult) rest) ) ) ) )
    78     (next$ base (+ base base) strm) )
    79   (let ((first (stream-car strm))
    80         (rest (stream-cdr strm)))
    81     (stream-cons first (prime-sieve$ (sift$ first rest))) ) )
    82 
    83 (define prime-numbers-stream (prime-sieve$ (stream-from 2)))
    84 |#
    85 
    86 (define prime-numbers-stream
    87   (stream-cons 2 (stream-filter prime-number? (stream-drop 2 natural-numbers-stream))) )
    88 
    89 (define (prime-number? n)
    90   ;
    91   (define (iter s)
    92     (let (
    93       (np (stream-car s)) )
    94       (cond
    95         ((> np (sqrt n))      #t)
    96         ((= 0 (modulo n np))  #f)
    97         (else                 (iter (stream-cdr s)) ) ) ) )
    98   ;
    99   (iter prime-numbers-stream) )
    100 
    101 ;; http://www.research.att.com/~njas/sequences/A051037
    102 
    103 (define hamming-sequence-stream
    104   (stream-cons 1
    105     (stream-unique =
    106       (stream-merge <
    107         (stream-map (left-section * 2) hamming-sequence-stream)
    108         (stream-map (left-section * 3) hamming-sequence-stream)
    109         (stream-map (left-section * 5) hamming-sequence-stream)))) )
    110 
    111 #;
    112 (define power-table
    113   (stream-of
    114     (stream-of (expt m n) (m in (stream-from 1)))
    115     (n in (stream-from 2))))
    116 
    117 (define fibonacci-stream
    118   (stream-cons 0
    119     (stream-cons 1
    120       (stream-map +
    121         fibonacci-stream
    122         (stream-cdr fibonacci-stream)))))
     28(include-relative "streams-math.incl")
    12329
    12430) ;module streams-math
  • release/5/srfi-41/trunk/streams-primitive.scm

    r39713 r39989  
    11;;;; streams-primitive.scm  -*- Scheme -*-
    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.
    172
    183(module streams-primitive
     
    4934  record-variants)
    5035
    51 ;;;
    52 
    53 ;; ensure identifier defined
    54 (define stream 'stream)
    55 (define-record-type-variant stream (unsafe unchecked inline)
    56   (%make-stream prom)
    57   (%stream?)
    58   (prom %stream-promise %stream-promise-set!) )
    59 
    60 (define-inline (stream-tagged-pair? obj)
    61   (and
    62     (pair? obj)
    63     (let ((tag (car obj)))
    64       (or (eq? 'lazy tag) (eq? 'eager tag)) ) ) )
    65 
    66 (define-inline (make-stream-box tag obj) (cons tag obj))
    67 (define-inline (stream-box-tag box) (car box))
    68 (define-inline (stream-box-value box) (cdr box))
    69 (define-inline (stream-box-tag-set! box tag) (set-car! box tag))
    70 (define-inline (stream-box-value-set! box val) (set-cdr! box val))
    71 
    72 (define-inline (make-stream-lazy-box obj) (make-stream-box 'lazy obj))
    73 (define-inline (make-stream-eager-box obj) (make-stream-box 'eager obj))
    74 
    75 (define-inline (stream-lazy-box? obj) (eq? 'lazy (stream-box-tag obj)))
    76 (define-inline (stream-eager-box? obj) (eq? 'eager (stream-box-tag obj)))
    77 
    78 (define-inline (check-stream-box loc obj)
    79   (unless (stream-tagged-pair? obj)
    80     (error-argument-type loc obj "stream-box") )
    81   obj )
    82 
    83 (define (stream-print obj out)
    84   (display "#<" out)
    85   (let ((promise (%stream-promise obj)))
    86     (cond
    87       ((stream-eager-box? promise)  (display "eager stream" out))
    88       ((stream-lazy-box? promise)   (display "lazy stream" out))
    89       (else
    90         (display "unknown stream " out) (display promise out)) ) )
    91   (display ">" out) )
    92 
    93 ;;;
    94 
    95 (define ($make-stream-lazy$ thunk) (%make-stream (make-stream-lazy-box thunk)))
    96 (define ($make-stream-eager$ obj) (%make-stream (make-stream-eager-box obj)))
    97 
    98 (define-syntax $stream-lazy$
    99   (syntax-rules ()
    100     (($stream-lazy$ ?expr)
    101       ($make-stream-lazy$ (lambda () ?expr)) ) ) )
    102 
    103 (define-syntax $stream-eager$
    104   (syntax-rules ()
    105     (($stream-eager$ ?expr)
    106       ($make-stream-eager$ ?expr) ) ) )
    107 
    108 (define-syntax $stream-delay$
    109   (syntax-rules ()
    110     (($stream-delay$ ?expr)
    111       ($stream-lazy$ ($stream-eager$ ?expr)) ) ) )
    112 
    113 ;;;
    114 
    115 (define (stream? obj) (%stream? obj))
    116 
    117 (define-check+error-type stream)
    118 
    119 (define (stream-force prom)
    120   (let* (
    121     (content (%stream-promise (check-stream #f prom)))
    122     (promise-box-value (stream-box-value content)) )
    123     ;better be there! (check-stream-box #f content)
    124     (case (stream-box-tag content)
    125       ((eager)
    126         promise-box-value )
    127       ((lazy)
    128         (let* (
    129           (prom* (promise-box-value))
    130           ;re-fetch promise in case changed by recursion via above call.
    131           (content (%stream-promise prom)) )
    132           ;re-establish bona-fides
    133           (check-stream #f prom*)
    134           ;better be there! (check-stream-box #f content)
    135           (unless (eq? 'eager (stream-box-tag content))
    136             (let ((content* (%stream-promise prom*)))
    137               (stream-box-tag-set! content (stream-box-tag content*))
    138               (stream-box-value-set! content (stream-box-value content*)) )
    139             (%stream-promise-set! prom* content) )
    140           (stream-force prom) ) ) ) ) )
    141 
    142 (define stream-null ($stream-delay$ (cons 'stream 'null)))
    143 
    144 (define-inline (*stream-null? strm)
    145   (eq? (stream-force strm) (stream-force stream-null)) )
    146 
    147 (define (stream-null? obj) (and (%stream? obj) (*stream-null? obj)))
    148 (define (stream-occupied? obj) (and (%stream? obj) (not (*stream-null? obj))))
    149 
    150 (define-check+error-type stream-occupied)
    151 
    152 (define-syntax stream-lambda
    153   (syntax-rules ()
    154     ((stream-lambda ?formals ?body0 ?body1 ...)
    155      (lambda ?formals ($stream-lazy$ (let () ?body0 ?body1 ...))) ) ) )
    156 
    157 ;;
    158 
    159 ;; ensure identifier defined
    160 (define stream-pair 'stream-pair)
    161 (define-record-type-variant stream-pair (unsafe unchecked inline)
    162   (%make-stream-pair hd tl)
    163   (%stream-pair?)
    164   (hd %stream-car)
    165   (tl %stream-cdr) )
    166 
    167 ;want inline car/cdr but need exportable procedure for make.
    168 (define ($make-stream-pair$ hd tl) (%make-stream-pair hd tl))
    169 
    170 (define-error-type stream-pair)
    171 
    172 (define-inline (checked-stream-pair loc obj)
    173   (cond
    174     ((not (%stream? obj))
    175       (error-stream loc obj 'stream) )
    176     ((*stream-null? obj)
    177       (error-stream-occupied loc obj 'stream) )
    178     (else
    179       (let ((val (stream-force obj)))
    180         (if (%stream-pair? val)
    181           val
    182           (error-stream-pair loc val 'stream)) ) ) ) )
    183 
    184 (define (stream-pair-print obj out)
    185   (display "#<" out)
    186   (display (%stream-car obj) out)
    187   (display " " out)
    188   (display (%stream-cdr obj) out)
    189   (display ">" out) )
    190 
    191 (define-syntax stream-cons
    192   (syntax-rules ()
    193     ((_ ?expr ?strm)
    194       ($stream-eager$ ($make-stream-pair$ ($stream-delay$ ?expr) ($stream-lazy$ ?strm))) ) ) )
    195 
    196 (define (stream-pair? obj)
    197   (and (%stream? obj) (%stream-pair? (stream-force obj))) )
    198 
    199 (define (stream-car strm)
    200   (stream-force (%stream-car (checked-stream-pair 'stream-car strm))) )
    201 
    202 (define (stream-cdr strm)
    203   (%stream-cdr (checked-stream-pair 'stream-cdr strm)) )
    204 
    205 ;;;
    206 
    207 (set! (record-printer stream) stream-print)
    208 
    209 (set! (record-printer stream-pair) stream-pair-print)
     36(include-relative "streams-primitive.incl")
    21037
    21138) ;module streams-primitive
  • release/5/srfi-41/trunk/streams-queue.scm

    r39713 r39989  
    11;;;; streams-queue.scm  -*- Scheme -*-
    2 ;;;; Kon Lovett, Feb '19
    3 ;;;; Kon Lovett, Aug '10
    4 
    5 ;;;; From "samples.ss"
    6 ;;;; Provides a functional queue abstraction using streams.
    72
    83(module streams-queue
     
    2722  streams)
    2823
    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))
     24(include-relative "streams-queue.incl")
    7025
    7126) ;streams-queue
  • release/5/srfi-41/trunk/streams-utils.scm

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

    r39707 r39989  
    2323  (chicken platform))
    2424
    25 (import streams-primitive streams-derived)
    26 (reexport streams-primitive streams-derived)
     25(import (streams primitive) (streams derived))
     26(reexport (streams primitive) (streams derived))
    2727
    2828(register-feature! 'streams)
  • release/5/srfi-41/trunk/tests/srfi-41-test.scm

    r39711 r39989  
    1919  type-errors
    2020  streams
    21   streams-utils
    22   streams-math
    23   streams-queue)
     21  (streams utils)
     22  (streams math)
     23  (streams queue))
    2424
    2525;;;
Note: See TracChangeset for help on using the changeset viewer.