1; Library streams/derived 2; Adapted for PLT Scheme by Jacob J. A. Koot 3; from original version of Philip L. Bewig. 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. 18 19#lang scheme 20 21(provide define-stream list->stream port->stream stream stream->list 22 stream-append stream-concat stream-constant stream-drop 23 stream-drop-while stream-filter stream-fold stream-for-each stream-from 24 stream-iterate stream-length stream-let stream-map stream-match _ 25 stream-of stream-range stream-ref stream-reverse stream-scan stream-take 26 stream-take-while stream-unfold stream-unfolds stream-zip) 27 28(require "primitive.rkt") 29 30(define-syntax define-stream 31 (syntax-rules () 32 ((define-stream (name . formal) body0 body1 ...) 33 (define name (stream-lambda formal body0 body1 ...))))) 34 35(define (list->stream objs) 36 (define list->stream 37 (stream-lambda (objs) 38 (if (null? objs) 39 stream-null 40 (stream-cons (car objs) (list->stream (cdr objs)))))) 41 (if (not (list? objs)) 42 (error 'list->stream "non-list argument") 43 (list->stream objs))) 44 45(define (port->stream . port) 46 (define port->stream 47 (stream-lambda (p) 48 (let ((c (read-char p))) 49 (if (eof-object? c) 50 stream-null 51 (stream-cons c (port->stream p)))))) 52 (let ((p (if (null? port) (current-input-port) (car port)))) 53 (if (not (input-port? p)) 54 (error 'port->stream "non-input-port argument") 55 (port->stream p)))) 56 57(define-syntax stream 58 (syntax-rules () 59 ((stream) stream-null) 60 ((stream x y ...) (stream-cons x (stream y ...))))) 61 62(define (stream->list . args) 63 (let ((n (if (= 1 (length args)) #f (car args))) 64 (strm (if (= 1 (length args)) (car args) (cadr args)))) 65 (cond ((not (stream? strm)) (error 'stream->list "non-stream argument")) 66 ((and n (not (integer? n))) (error 'stream->list "non-integer count")) 67 ((and n (negative? n)) (error 'stream->list "negative count")) 68 (else (let loop ((n (if n n -1)) (strm strm)) 69 (if (or (zero? n) (stream-null? strm)) 70 '() 71 (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))))))))) 72 73(define (stream-append . strms) 74 (define stream-append 75 (stream-lambda (strms) 76 (cond ((null? (cdr strms)) (car strms)) 77 ((stream-null? (car strms)) (stream-append (cdr strms))) 78 (else (stream-cons (stream-car (car strms)) 79 (stream-append (cons (stream-cdr (car strms)) (cdr strms)))))))) 80 (cond ((null? strms) stream-null) 81 ((ormap (lambda (x) (not (stream? x))) strms) 82 (error 'stream-append "non-stream argument")) 83 (else (stream-append strms)))) 84 85(define (stream-concat strms) 86 (define stream-concat 87 (stream-lambda (strms) 88 (cond ((stream-null? strms) stream-null) 89 ((not (stream? (stream-car strms))) 90 (error 'stream-concat "non-stream object in input stream")) 91 ((stream-null? (stream-car strms)) 92 (stream-concat (stream-cdr strms))) 93 (else (stream-cons 94 (stream-car (stream-car strms)) 95 (stream-concat 96 (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms)))))))) 97 (if (not (stream? strms)) 98 (error 'stream-concat "non-stream argument") 99 (stream-concat strms))) 100 101(define (stream-constant . objs) 102 (cond ((null? objs) stream-null) 103 ((null? (cdr objs)) (stream-let loop () (stream-cons (car objs) (loop)))) 104 (else (let ((strm (list->stream objs))) 105 (stream-let loop () (stream-append strm (loop))))))) 106 107(define (stream-drop n strm) 108 (define stream-drop 109 (stream-lambda (n strm) 110 (if (or (zero? n) (stream-null? strm)) 111 strm 112 (stream-drop (- n 1) (stream-cdr strm))))) 113 (cond ((not (integer? n)) (error 'stream-drop "non-integer argument")) 114 ((negative? n) (error 'stream-drop "negative argument")) 115 ((not (stream? strm)) (error 'stream-drop "non-stream argument")) 116 (else (stream-drop n strm)))) 117 118(define (stream-drop-while pred? strm) 119 (define stream-drop-while 120 (stream-lambda (strm) 121 (if (and (stream-pair? strm) (pred? (stream-car strm))) 122 (stream-drop-while (stream-cdr strm)) 123 strm))) 124 (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument")) 125 ((not (stream? strm)) (error 'stream-drop-while "non-stream argument")) 126 (else (stream-drop-while strm)))) 127 128(define (stream-filter pred? strm) 129 (define stream-filter 130 (stream-lambda (strm) 131 (cond ((stream-null? strm) stream-null) 132 ((pred? (stream-car strm)) 133 (stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) 134 (else (stream-filter (stream-cdr strm)))))) 135 (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument")) 136 ((not (stream? strm)) (error 'stream-filter "non-stream argument")) 137 (else (stream-filter strm)))) 138 139(define (stream-fold proc base strm) 140 (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument")) 141 ((not (stream? strm)) (error 'stream-fold "non-stream argument")) 142 (else (let loop ((base base) (strm strm)) 143 (if (stream-null? strm) 144 base 145 (loop (proc base (stream-car strm)) (stream-cdr strm))))))) 146 147(define (stream-for-each proc . strms) 148 (define (stream-for-each strms) 149 (when (not (ormap stream-null? strms)) 150 (begin (apply proc (map stream-car strms)) 151 (stream-for-each (map stream-cdr strms))))) 152 (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument")) 153 ((null? strms) (error 'stream-for-each "no stream arguments")) 154 ((ormap (lambda (x) (not (stream? x))) strms) 155 (error 'stream-for-each "non-stream argument")) 156 (else (stream-for-each strms)))) 157 158(define (stream-from first . step) 159 (define stream-from 160 (stream-lambda (first delta) 161 (stream-cons first (stream-from (+ first delta) delta)))) 162 (let ((delta (if (null? step) 1 (car step)))) 163 (cond ((not (number? first)) (error 'stream-from "non-numeric starting number")) 164 ((not (number? delta)) (error 'stream-from "non-numeric step size")) 165 (else (stream-from first delta))))) 166 167(define (stream-iterate proc base) 168 (define stream-iterate 169 (stream-lambda (base) 170 (stream-cons base (stream-iterate (proc base))))) 171 (if (not (procedure? proc)) 172 (error 'stream-iterate "non-procedural argument") 173 (stream-iterate base))) 174 175(define (stream-length strm) 176 (if (not (stream? strm)) 177 (error 'stream-length "non-stream argument") 178 (let loop ((len 0) (strm strm)) 179 (if (stream-null? strm) 180 len 181 (loop (+ len 1) (stream-cdr strm)))))) 182 183(define-syntax stream-let 184 (syntax-rules () 185 ((stream-let tag ((name val) ...) body1 body2 ...) 186 ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...)))) 187 188(define (stream-map proc . strms) 189 (define stream-map 190 (stream-lambda (strms) 191 (if (ormap stream-null? strms) 192 stream-null 193 (stream-cons (apply proc (map stream-car strms)) 194 (stream-map (map stream-cdr strms)))))) 195 (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument")) 196 ((null? strms) (error 'stream-map "no stream arguments")) 197 ((ormap (lambda (x) (not (stream? x))) strms) 198 (error 'stream-map "non-stream argument")) 199 (else (stream-map strms)))) 200 201(define-syntax stream-match 202 (syntax-rules () 203 ((stream-match strm-expr clause ...) 204 (let ((strm strm-expr)) 205 (cond 206 ((not (stream? strm)) (error 'stream-match "non-stream argument")) 207 ((stream-match-test strm clause) => car) ... 208 (else (error 'stream-match "pattern failure"))))))) 209 210(define-syntax stream-match-test 211 (syntax-rules () 212 ((stream-match-test strm (pattern fender expr)) 213 (stream-match-pattern strm pattern () (and fender (list expr)))) 214 ((stream-match-test strm (pattern expr)) 215 (stream-match-pattern strm pattern () (list expr))))) 216 217(define-syntax stream-match-pattern 218 (lambda (x) 219 (define (wildcard? x) 220 (and (identifier? x) 221 (free-identifier=? x (syntax _)))) 222 (syntax-case x () 223 ((stream-match-pattern strm () (binding ...) body) 224 (syntax (and (stream-null? strm) (let (binding ...) body)))) 225 ((stream-match-pattern strm (w? . rest) (binding ...) body) 226 (wildcard? #'w?) 227 (syntax (and (stream-pair? strm) 228 (let ((strm (stream-cdr strm))) 229 (stream-match-pattern strm rest (binding ...) body))))) 230 ((stream-match-pattern strm (var . rest) (binding ...) body) 231 (syntax (and (stream-pair? strm) 232 (let ((temp (stream-car strm)) (strm (stream-cdr strm))) 233 (stream-match-pattern strm rest ((var temp) binding ...) body))))) 234 ((stream-match-pattern strm w? (binding ...) body) 235 (wildcard? #'w?) 236 (syntax (let (binding ...) body))) 237 ((stream-match-pattern strm var (binding ...) body) 238 (syntax (let ((var strm) binding ...) body)))))) 239 240(define-syntax stream-of 241 (syntax-rules () 242 ((_ expr rest ...) 243 (stream-of-aux expr stream-null rest ...)))) 244 245(define-syntax stream-of-aux 246 (syntax-rules (in is) 247 ((stream-of-aux expr base) 248 (stream-cons expr base)) 249 ((stream-of-aux expr base (var in stream) rest ...) 250 (stream-let loop ((strm stream)) 251 (if (stream-null? strm) 252 base 253 (let ((var (stream-car strm))) 254 (stream-of-aux expr (loop (stream-cdr strm)) rest ...))))) 255 ((stream-of-aux expr base (var is exp) rest ...) 256 (let ((var exp)) (stream-of-aux expr base rest ...))) 257 ((stream-of-aux expr base pred? rest ...) 258 (if pred? (stream-of-aux expr base rest ...) base)))) 259 260(define (stream-range first past . step) 261 (define stream-range 262 (stream-lambda (first past delta lt?) 263 (if (lt? first past) 264 (stream-cons first (stream-range (+ first delta) past delta lt?)) 265 stream-null))) 266 (cond ((not (number? first)) (error 'stream-range "non-numeric starting number")) 267 ((not (number? past)) (error 'stream-range "non-numeric ending number")) 268 (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) 269 (if (not (number? delta)) 270 (error 'stream-range "non-numeric step size") 271 (let ((lt? (if (< 0 delta) < >))) 272 (stream-range first past delta lt?))))))) 273 274(define (stream-ref strm n) 275 (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument")) 276 ((not (integer? n)) (error 'stream-ref "non-integer argument")) 277 ((negative? n) (error 'stream-ref "negative argument")) 278 (else (let loop ((strm strm) (n n)) 279 (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream")) 280 ((zero? n) (stream-car strm)) 281 (else (loop (stream-cdr strm) (- n 1)))))))) 282 283(define (stream-reverse strm) 284 (define stream-reverse 285 (stream-lambda (strm rev) 286 (if (stream-null? strm) 287 rev 288 (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev))))) 289 (if (not (stream? strm)) 290 (error 'stream-reverse "non-stream argument") 291 (stream-reverse strm stream-null))) 292 293(define (stream-scan proc base strm) 294 (define stream-scan 295 (stream-lambda (base strm) 296 (if (stream-null? strm) 297 (stream base) 298 (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm)))))) 299 (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument")) 300 ((not (stream? strm)) (error 'stream-scan "non-stream argument")) 301 (else (stream-scan base strm)))) 302 303(define (stream-take n strm) 304 (define stream-take 305 (stream-lambda (n strm) 306 (if (or (stream-null? strm) (zero? n)) 307 stream-null 308 (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm)))))) 309 (cond ((not (stream? strm)) (error 'stream-take "non-stream argument")) 310 ((not (integer? n)) (error 'stream-take "non-integer argument")) 311 ((negative? n) (error 'stream-take "negative argument")) 312 (else (stream-take n strm)))) 313 314(define (stream-take-while pred? strm) 315 (define stream-take-while 316 (stream-lambda (strm) 317 (cond ((stream-null? strm) stream-null) 318 ((pred? (stream-car strm)) 319 (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm)))) 320 (else stream-null)))) 321 (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument")) 322 ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument")) 323 (else (stream-take-while strm)))) 324 325(define (stream-unfold mapper pred? generator base) 326 (define stream-unfold 327 (stream-lambda (base) 328 (if (pred? base) 329 (stream-cons (mapper base) (stream-unfold (generator base))) 330 stream-null))) 331 (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper")) 332 ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?")) 333 ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator")) 334 (else (stream-unfold base)))) 335 336(define (stream-unfolds gen seed) 337 (define (len-values gen seed) 338 (call-with-values 339 (lambda () (gen seed)) 340 (lambda vs (- (length vs) 1)))) 341 (define unfold-result-stream 342 (stream-lambda (gen seed) 343 (call-with-values 344 (lambda () (gen seed)) 345 (lambda (next . results) 346 (stream-cons results (unfold-result-stream gen next)))))) 347 (define result-stream->output-stream 348 (stream-lambda (result-stream i) 349 (let ((result (list-ref (stream-car result-stream) (- i 1)))) 350 (cond ((pair? result) 351 (stream-cons 352 (car result) 353 (result-stream->output-stream (stream-cdr result-stream) i))) 354 ((not result) 355 (result-stream->output-stream (stream-cdr result-stream) i)) 356 ((null? result) stream-null) 357 (else (error 'stream-unfolds "can't happen")))))) 358 (define (result-stream->output-streams result-stream) 359 (let loop ((i (len-values gen seed)) (outputs '())) 360 (if (zero? i) 361 (apply values outputs) 362 (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs))))) 363 (if (not (procedure? gen)) 364 (error 'stream-unfolds "non-procedural argument") 365 (result-stream->output-streams (unfold-result-stream gen seed)))) 366 367(define (stream-zip . strms) 368 (define stream-zip 369 (stream-lambda (strms) 370 (if (ormap stream-null? strms) 371 stream-null 372 (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms)))))) 373 (cond ((null? strms) (error 'stream-zip "no stream arguments")) 374 ((ormap (lambda (x) (not (stream? x))) strms) 375 (error 'stream-zip "non-stream argument")) 376 (else (stream-zip strms)))) 377