mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Add SRFI-41.

Browse source 
Incorporates suggestions from Mark H Weaver <mhw@netris.org>
and Ian Price <ianprice90@googlemail.com>.

* module/srfi/srfi-41.scm: New file.

* module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-41.scm.

* test-suite/tests/srfi-41.test: New file.

* test-suite/Makefile.am (SCM_TESTS): Add tests/srfi-41.test.

* doc/ref/srfi-modules.texi (SRFI Support): Add SRFI-41.
  (SRFI-41): New node which refers the reader to
  <http://srfi.schemers.org/srfi-41/srfi-41.html>.
This commit is contained in:
Chris K. Jester-Young 2013-03-26 22:15:31 -04:00 • committed by Mark H Weaver
parent ed4aa26489
commit 50d08cd894
5 changed files with 1172 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

8
doc/ref/srfi-modules.texi
View file

@ -45,6 +45,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-37:: args-fold program argument processor
* SRFI-38:: External Representation for Data With Shared Structure
* SRFI-39:: Parameter objects
* SRFI-41:: Streams.
* SRFI-42:: Eager comprehensions
* SRFI-45:: Primitives for expressing iterative lazy algorithms
* SRFI-55:: Requiring Features.
@ -3788,6 +3789,13 @@ scope and the result from that @var{thunk} is the return from
@code{with-parameters*}.
@end defun
@node SRFI-41
@subsection SRFI-41 - Streams
@cindex SRFI-41
See @uref{http://srfi.schemers.org/srfi-41/srfi-41.html, the
specification of SRFI-41}.
@node SRFI-42
@subsection SRFI-42 - Eager Comprehensions
@cindex SRFI-42

1
module/Makefile.am
View file

@ -282,6 +282,7 @@ SRFI_SOURCES = \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
srfi/srfi-38.scm \
srfi/srfi-41.scm \
srfi/srfi-42.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \

482
module/srfi/srfi-41.scm Normal file
View file

@ -0,0 +1,482 @@
;;; srfi-41.scm -- SRFI 41 streams
;; Copyright (c) 2007 Philip L. Bewig
;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
(define-module (srfi srfi-41)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (stream-null stream-cons stream? stream-null? stream-pair?
stream-car stream-cdr stream-lambda define-stream
list->stream port->stream stream stream->list stream-append
stream-concat stream-constant stream-drop stream-drop-while
stream-filter stream-fold stream-for-each stream-from
stream-iterate stream-length stream-let stream-map
stream-match stream-of stream-range stream-ref stream-reverse
stream-scan stream-take stream-take-while stream-unfold
stream-unfolds stream-zip))
(cond-expand-provide (current-module) '(srfi-41))
;;; Private supporting functions and macros.
(define-syntax-rule (must pred obj func msg args ...)
(let ((item obj))
(unless (pred item)
(throw 'wrong-type-arg func msg (list args ...) (list item)))))
(define-syntax-rule (must-not pred obj func msg args ...)
(let ((item obj))
(when (pred item)
(throw 'wrong-type-arg func msg (list args ...) (list item)))))
(define-syntax-rule (must-every pred objs func msg args ...)
(let ((flunk (remove pred objs)))
(unless (null? flunk)
(throw 'wrong-type-arg func msg (list args ...) flunk))))
(define-syntax-rule (first-value expr)
(receive (first . _) expr
first))
(define-syntax-rule (second-value expr)
(receive (first second . _) expr
second))
(define-syntax-rule (third-value expr)
(receive (first second third . _) expr
third))
(define-syntax define-syntax*
(syntax-rules ()
((_ (name . args) body ...)
(define-syntax name (lambda* args body ...)))
((_ name syntax)
(define-syntax name syntax))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Here we include a copy of the code of srfi-45.scm (but with renamed
;; identifiers), in order to create a new promise type that's disjoint
;; from the promises created by srfi-45. Ideally this should be done
;; using a 'make-promise-type' macro that instantiates a copy of this
;; code, but a psyntax bug in Guile 2.0 prevents this from working
;; properly: <http://bugs.gnu.org/13995>. So for now, we duplicate the
;; code.
;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
(define-record-type stream-promise (make-stream-promise val) stream-promise?
(val stream-promise-val stream-promise-val-set!))
(define-record-type stream-value (make-stream-value tag proc) stream-value?
(tag stream-value-tag stream-value-tag-set!)
(proc stream-value-proc stream-value-proc-set!))
(define-syntax-rule (stream-lazy exp)
(make-stream-promise (make-stream-value 'lazy (lambda () exp))))
(define (stream-eager x)
(make-stream-promise (make-stream-value 'eager x)))
(define-syntax-rule (stream-delay exp)
(stream-lazy (stream-eager exp)))
(define (stream-force promise)
(let ((content (stream-promise-val promise)))
(case (stream-value-tag content)
((eager) (stream-value-proc content))
((lazy) (let* ((promise* ((stream-value-proc content)))
(content (stream-promise-val promise)))
(if (not (eqv? (stream-value-tag content) 'eager))
(begin (stream-value-tag-set! content
(stream-value-tag (stream-promise-val promise*)))
(stream-value-proc-set! content
(stream-value-proc (stream-promise-val promise*)))
(stream-promise-val-set! promise* content)))
(stream-force promise))))))
;;
;; End of the copy of the code from srfi-45.scm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Primitive stream functions and macros: (streams primitive)
(define stream? stream-promise?)
(define %stream-null '(stream . null))
(define stream-null (stream-eager %stream-null))
(define (stream-null? obj)
(and (stream-promise? obj)
(eqv? (stream-force obj) %stream-null)))
(define-record-type stream-pare (make-stream-pare kar kdr) stream-pare?
(kar stream-kar)
(kdr stream-kdr))
(define (stream-pair? obj)
(and (stream-promise? obj) (stream-pare? (stream-force obj))))
(define-syntax-rule (stream-cons obj strm)
(stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))
(define (stream-car strm)
(must stream? strm 'stream-car "non-stream")
(let ((pare (stream-force strm)))
(must stream-pare? pare 'stream-car "null stream")
(stream-force (stream-kar pare))))
(define (stream-cdr strm)
(must stream? strm 'stream-cdr "non-stream")
(let ((pare (stream-force strm)))
(must stream-pare? pare 'stream-cdr "null stream")
(stream-kdr pare)))
(define-syntax-rule (stream-lambda formals body0 body1 ...)
(lambda formals (stream-lazy (begin body0 body1 ...))))
;;; Derived stream functions and macros: (streams derived)
(define-syntax-rule (define-stream (name . formal) body0 body1 ...)
(define name (stream-lambda formal body0 body1 ...)))
(define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...)
((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))
(define (list->stream objs)
(define (list? x)
(or (proper-list? x) (circular-list? x)))
(must list? objs 'list->stream "non-list argument")
(stream-let recur ((objs objs))
(if (null? objs) stream-null
(stream-cons (car objs) (recur (cdr objs))))))
(define* (port->stream #:optional (port (current-input-port)))
(must input-port? port 'port->stream "non-input-port argument")
(stream-let recur ()
(let ((c (read-char port)))
(if (eof-object? c) stream-null
(stream-cons c (recur))))))
(define-syntax stream
(syntax-rules ()
((_) stream-null)
((_ x y ...) (stream-cons x (stream y ...)))))
;; Common helper for the various eager-folding functions, such as
;; stream-fold, stream-drop, stream->list, stream-length, etc.
(define-inlinable (stream-fold-aux proc base strm limit)
(do ((val base (and proc (proc val (stream-car strm))))
(strm strm (stream-cdr strm))
(limit limit (and limit (1- limit))))
((or (and limit (zero? limit)) (stream-null? strm))
(values val strm limit))))
(define stream->list
(case-lambda
((strm) (stream->list #f strm))
((n strm)
(must stream? strm 'stream->list "non-stream argument")
(when n
(must integer? n 'stream->list "non-integer count")
(must exact? n 'stream->list "inexact count")
(must-not negative? n 'stream->list "negative count"))
(reverse! (first-value (stream-fold-aux xcons '() strm n))))))
(define (stream-append . strms)
(must-every stream? strms 'stream-append "non-stream argument")
(stream-let recur ((strms strms))
(if (null? strms) stream-null
(let ((strm (car strms)))
(if (stream-null? strm) (recur (cdr strms))
(stream-cons (stream-car strm)
(recur (cons (stream-cdr strm) (cdr strms)))))))))
(define (stream-concat strms)
(must stream? strms 'stream-concat "non-stream argument")
(stream-let recur ((strms strms))
(if (stream-null? strms) stream-null
(let ((strm (stream-car strms)))
(must stream? strm 'stream-concat "non-stream object in input stream")
(if (stream-null? strm) (recur (stream-cdr strms))
(stream-cons (stream-car strm)
(recur (stream-cons (stream-cdr strm)
(stream-cdr strms)))))))))
(define stream-constant
(case-lambda
(() stream-null)
(objs (list->stream (apply circular-list objs)))))
(define-syntax* (stream-do x)
(define (end x)
(syntax-case x ()
(() #'(if #f #f))
((result) #'result)
((result ...) #'(begin result ...))))
(define (var-step v s)
(syntax-case s ()
(() v)
((e) #'e)
(_ (syntax-violation 'stream-do "bad step expression" x s))))
(syntax-case x ()
((_ ((var init . step) ...)
(test result ...)
expr ...)
(with-syntax ((result (end #'(result ...)))
((step ...) (map var-step #'(var ...) #'(step ...))))
#'(stream-let loop ((var init) ...)
(if test result
(begin
expr ...
(loop step ...))))))))
(define (stream-drop n strm)
(must integer? n 'stream-drop "non-integer argument")
(must exact? n 'stream-drop "inexact argument")
(must-not negative? n 'stream-drop "negative argument")
(must stream? strm 'stream-drop "non-stream argument")
(second-value (stream-fold-aux #f #f strm n)))
(define (stream-drop-while pred? strm)
(must procedure? pred? 'stream-drop-while "non-procedural argument")
(must stream? strm 'stream-drop-while "non-stream argument")
(stream-do ((strm strm (stream-cdr strm)))
((or (stream-null? strm) (not (pred? (stream-car strm)))) strm)))
(define (stream-filter pred? strm)
(must procedure? pred? 'stream-filter "non-procedural argument")
(must stream? strm 'stream-filter "non-stream argument")
(stream-let recur ((strm strm))
(cond ((stream-null? strm) stream-null)
((pred? (stream-car strm))
(stream-cons (stream-car strm) (recur (stream-cdr strm))))
(else (recur (stream-cdr strm))))))
(define (stream-fold proc base strm)
(must procedure? proc 'stream-fold "non-procedural argument")
(must stream? strm 'stream-fold "non-stream argument")
(first-value (stream-fold-aux proc base strm #f)))
(define stream-for-each
(case-lambda
((proc strm)
(must procedure? proc 'stream-for-each "non-procedural argument")
(must stream? strm 'stream-for-each "non-stream argument")
(do ((strm strm (stream-cdr strm)))
((stream-null? strm))
(proc (stream-car strm))))
((proc strm . rest)
(let ((strms (cons strm rest)))
(must procedure? proc 'stream-for-each "non-procedural argument")
(must-every stream? strms 'stream-for-each "non-stream argument")
(do ((strms strms (map stream-cdr strms)))
((any stream-null? strms))
(apply proc (map stream-car strms)))))))
(define* (stream-from first #:optional (step 1))
(must number? first 'stream-from "non-numeric starting number")
(must number? step 'stream-from "non-numeric step size")
(stream-let recur ((first first))
(stream-cons first (recur (+ first step)))))
(define (stream-iterate proc base)
(must procedure? proc 'stream-iterate "non-procedural argument")
(stream-let recur ((base base))
(stream-cons base (recur (proc base)))))
(define (stream-length strm)
(must stream? strm 'stream-length "non-stream argument")
(- -1 (third-value (stream-fold-aux #f #f strm -1))))
(define stream-map
(case-lambda
((proc strm)
(must procedure? proc 'stream-map "non-procedural argument")
(must stream? strm 'stream-map "non-stream argument")
(stream-let recur ((strm strm))
(if (stream-null? strm) stream-null
(stream-cons (proc (stream-car strm))
(recur (stream-cdr strm))))))
((proc strm . rest)
(let ((strms (cons strm rest)))
(must procedure? proc 'stream-map "non-procedural argument")
(must-every stream? strms 'stream-map "non-stream argument")
(stream-let recur ((strms strms))
(if (any stream-null? strms) stream-null
(stream-cons (apply proc (map stream-car strms))
(recur (map stream-cdr strms)))))))))
(define-syntax* (stream-match x)
(define (make-matcher x)
(syntax-case x ()
(() #'(? stream-null?))
(rest (identifier? #'rest) #'rest)
((var . rest) (identifier? #'var)
(with-syntax ((next (make-matcher #'rest)))
#'(? (negate stream-null?)
(= stream-car var)
(= stream-cdr next))))))
(define (make-guarded x fail)
(syntax-case (list x fail) ()
(((expr) _) #'expr)
(((guard expr) fail) #'(if guard expr (fail)))))
(syntax-case x ()
((_ strm-expr (pat . expr) ...)
(with-syntax (((fail ...) (generate-temporaries #'(pat ...))))
(with-syntax (((matcher ...) (map make-matcher #'(pat ...)))
((expr ...) (map make-guarded #'(expr ...) #'(fail ...))))
#'(let ((strm strm-expr))
(must stream? strm 'stream-match "non-stream argument")
(match strm (matcher (=> fail) expr) ...)))))))
(define-syntax-rule (stream-of expr rest ...)
(stream-of-aux expr stream-null rest ...))
(define-syntax stream-of-aux
(syntax-rules (in is)
((_ expr base)
(stream-cons expr base))
((_ expr base (var in stream) rest ...)
(stream-let recur ((strm stream))
(if (stream-null? strm) base
(let ((var (stream-car strm)))
(stream-of-aux expr (recur (stream-cdr strm)) rest ...)))))
((_ expr base (var is exp) rest ...)
(let ((var exp)) (stream-of-aux expr base rest ...)))
((_ expr base pred? rest ...)
(if pred? (stream-of-aux expr base rest ...) base))))
(define* (stream-range first past #:optional step)
(must number? first 'stream-range "non-numeric starting number")
(must number? past 'stream-range "non-numeric ending number")
(when step
(must number? step 'stream-range "non-numeric step size"))
(let* ((step (or step (if (< first past) 1 -1)))
(lt? (if (< 0 step) < >)))
(stream-let recur ((first first))
(if (lt? first past)
(stream-cons first (recur (+ first step)))
stream-null))))
(define (stream-ref strm n)
(must stream? strm 'stream-ref "non-stream argument")
(must integer? n 'stream-ref "non-integer argument")
(must exact? n 'stream-ref "inexact argument")
(must-not negative? n 'stream-ref "negative argument")
(let ((res (stream-drop n strm)))
(must-not stream-null? res 'stream-ref "beyond end of stream")
(stream-car res)))
(define (stream-reverse strm)
(must stream? strm 'stream-reverse "non-stream argument")
(stream-do ((strm strm (stream-cdr strm))
(rev stream-null (stream-cons (stream-car strm) rev)))
((stream-null? strm) rev)))
(define (stream-scan proc base strm)
(must procedure? proc 'stream-scan "non-procedural argument")
(must stream? strm 'stream-scan "non-stream argument")
(stream-let recur ((base base) (strm strm))
(if (stream-null? strm) (stream base)
(stream-cons base (recur (proc base (stream-car strm))
(stream-cdr strm))))))
(define (stream-take n strm)
(must stream? strm 'stream-take "non-stream argument")
(must integer? n 'stream-take "non-integer argument")
(must exact? n 'stream-take "inexact argument")
(must-not negative? n 'stream-take "negative argument")
(stream-let recur ((n n) (strm strm))
(if (or (zero? n) (stream-null? strm)) stream-null
(stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm))))))
(define (stream-take-while pred? strm)
(must procedure? pred? 'stream-take-while "non-procedural argument")
(must stream? strm 'stream-take-while "non-stream argument")
(stream-let recur ((strm strm))
(cond ((stream-null? strm) stream-null)
((pred? (stream-car strm))
(stream-cons (stream-car strm) (recur (stream-cdr strm))))
(else stream-null))))
(define (stream-unfold mapper pred? generator base)
(must procedure? mapper 'stream-unfold "non-procedural mapper")
(must procedure? pred? 'stream-unfold "non-procedural pred?")
(must procedure? generator 'stream-unfold "non-procedural generator")
(stream-let recur ((base base))
(if (pred? base)
(stream-cons (mapper base) (recur (generator base)))
stream-null)))
(define (stream-unfolds gen seed)
(define-stream (generator-stream seed)
(receive (next . items) (gen seed)
(stream-cons (list->vector items) (generator-stream next))))
(define-stream (make-result-stream genstrm index)
(define head (vector-ref (stream-car genstrm) index))
(define-stream (tail) (make-result-stream (stream-cdr genstrm) index))
(match head
(() stream-null)
(#f (tail))
((item) (stream-cons item (tail)))
((? list? items) (stream-append (list->stream items) (tail)))))
(must procedure? gen 'stream-unfolds "non-procedural argument")
(let ((genstrm (generator-stream seed)))
(apply values (list-tabulate (vector-length (stream-car genstrm))
(cut make-result-stream genstrm <>)))))
(define (stream-zip strm . rest)
(let ((strms (cons strm rest)))
(must-every stream? strms 'stream-zip "non-stream argument")
(stream-let recur ((strms strms))
(if (any stream-null? strms) stream-null
(stream-cons (map stream-car strms) (recur (map stream-cdr strms)))))))

1
test-suite/Makefile.am
View file

@ -131,6 +131,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-37.test \
tests/srfi-38.test \
tests/srfi-39.test \
tests/srfi-41.test \
tests/srfi-42.test \
tests/srfi-45.test \
tests/srfi-60.test \

680
test-suite/tests/srfi-41.test Normal file
View file

@ -0,0 +1,680 @@
;;; srfi-41.test -- test suite for SRFI 41
;; Copyright (c) 2007 Philip L. Bewig
;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
(define-module (test-srfi-41)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-31)
#:use-module (srfi srfi-41)
#:use-module (test-suite lib))
(define-stream (qsort lt? strm)
(if (stream-null? strm) stream-null
(let ((x (stream-car strm))
(xs (stream-cdr strm)))
(stream-append
(qsort lt? (stream-filter (cut lt? <> x) xs))
(stream x)
(qsort lt? (stream-filter (cut (negate lt?) <> x) xs))))))
(define-stream (isort lt? strm)
(define-stream (insert strm x)
(stream-match strm
(() (stream x))
((y . ys) (if (lt? y x)
(stream-cons y (insert ys x))
(stream-cons x strm)))))
(stream-fold insert stream-null strm))
(define-stream (stream-merge lt? . strms)
(stream-let loop ((strms strms))
(cond ((null? strms) stream-null)
((null? (cdr strms)) (car strms))
(else (stream-let merge ((xx (car strms))
(yy (loop (cdr strms))))
(stream-match xx
(() yy)
((x . xs)
(stream-match yy
(() xx)
((y . ys)
(if (lt? y x)
(stream-cons y (merge xx ys))
(stream-cons x (merge xs yy))))))))))))
(define-stream (msort lt? strm)
(let* ((n (quotient (stream-length strm) 2))
(ts (stream-take n strm))
(ds (stream-drop n strm)))
(if (zero? n) strm
(stream-merge lt? (msort < ts) (msort < ds)))))
(define-stream (stream-unique eql? strm)
(if (stream-null? strm) stream-null
(stream-cons (stream-car strm)
(stream-unique eql?
(stream-drop-while (cut eql? (stream-car strm) <>) strm)))))
(define nats
(stream-cons 1
(stream-map 1+ nats)))
(define hamming
(stream-unique =
(stream-cons 1
(stream-merge <
(stream-map (cut * 2 <>) hamming)
(stream-merge <
(stream-map (cut * 3 <>) hamming)
(stream-map (cut * 5 <>) hamming))))))
(define primes (let ()
(define-stream (next base mult strm)
(let ((first (stream-car strm))
(rest (stream-cdr strm)))
(cond ((< first mult)
(stream-cons first
(next base mult rest)))
((< mult first)
(next base (+ base mult) strm))
(else (next base
(+ base mult) rest)))))
(define-stream (sift base strm)
(next base (+ base base) strm))
(stream-let sieve ((strm (stream-from 2)))
(let ((first (stream-car strm))
(rest (stream-cdr strm)))
(stream-cons first (sieve (sift first rest)))))))
(define strm123 (stream 1 2 3))
(define (stream-equal? s1 s2)
(cond ((and (stream-null? s1) (stream-null? s2)) #t)
((or (stream-null? s1) (stream-null? s2)) #f)
((equal? (stream-car s1) (stream-car s2))
(stream-equal? (stream-cdr s1) (stream-cdr s2)))
(else #f)))
(with-test-prefix "stream-null"
(pass-if "is a stream" (stream? stream-null))
(pass-if "is a null stream" (stream-null? stream-null))
(pass-if "is not a stream pair" (not (stream-pair? stream-null))))
(with-test-prefix "stream-cons"
(pass-if "is a stream" (stream? (stream-cons 1 stream-null)))
(pass-if "is not a null stream" (not (stream-null? (stream-cons 1 stream-null))))
(pass-if "is a stream pair" (stream-pair? (stream-cons 1 stream-null))))
(with-test-prefix "stream?"
(pass-if "is true for null stream" (stream? stream-null))
(pass-if "is true for stream pair" (stream? (stream-cons 1 stream-null)))
(pass-if "is false for non-stream" (not (stream? "four"))))
(with-test-prefix "stream-null?"
(pass-if "is true for null stream" (stream-null? stream-null))
(pass-if "is false for stream pair" (not (stream-null? (stream-cons 1 stream-null))))
(pass-if "is false for non-stream" (not (stream-null? "four"))))
(with-test-prefix "stream-pair?"
(pass-if "is false for null stream" (not (stream-pair? stream-null)))
(pass-if "is true for stream pair" (stream-pair? (stream-cons 1 stream-null)))
(pass-if "is false for non-stream" (not (stream-pair? "four"))))
(with-test-prefix "stream-car"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream")
(stream-car "four"))
(pass-if-exception "throws for null stream"
'(wrong-type-arg . "null stream")
(stream-car stream-null))
(pass-if "returns first of stream" (eqv? (stream-car strm123) 1)))
(with-test-prefix "stream-cdr"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream")
(stream-cdr "four"))
(pass-if-exception "throws for null stream"
'(wrong-type-arg . "null stream")
(stream-cdr stream-null))
(pass-if "returns rest of stream" (eqv? (stream-car (stream-cdr strm123)) 2)))
(with-test-prefix "stream-lambda"
(pass-if "returns correct result"
(stream-equal?
((rec double (stream-lambda (strm)
(if (stream-null? strm) stream-null
(stream-cons (* 2 (stream-car strm))
(double (stream-cdr strm))))))
strm123)
(stream 2 4 6))))
(with-test-prefix "define-stream"
(pass-if "returns correct result"
(stream-equal?
(let ()
(define-stream (double strm)
(if (stream-null? strm) stream-null
(stream-cons (* 2 (stream-car strm))
(double (stream-cdr strm)))))
(double strm123))
(stream 2 4 6))))
(with-test-prefix "list->stream"
(pass-if-exception "throws for non-list"
'(wrong-type-arg . "non-list argument")
(list->stream "four"))
(pass-if "returns empty stream for empty list"
(stream-null? (list->stream '())))
(pass-if "returns stream with same content as given list"
(stream-equal? (list->stream '(1 2 3)) strm123)))
(with-test-prefix "port->stream"
(pass-if-exception "throws for non-input-port"
'(wrong-type-arg . "non-input-port argument")
(port->stream "four"))
(call-with-input-string "Hello, world!"
(lambda (p)
(pass-if-equal "reads input string correctly"
"Hello, world!"
(list->string (stream->list (port->stream p)))))))
(with-test-prefix "stream"
(pass-if-equal "with empty stream"
'()
(stream->list (stream)))
(pass-if-equal "with one-element stream"
'(1)
(stream->list (stream 1)))
(pass-if-equal "with three-element stream"
'(1 2 3)
(stream->list strm123)))
(with-test-prefix "stream->list"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream->list '()))
(pass-if-exception "throws for non-integer count"
'(wrong-type-arg . "non-integer count")
(stream->list "four" strm123))
(pass-if-exception "throws for negative count"
'(wrong-type-arg . "negative count")
(stream->list -1 strm123))
(pass-if-equal "returns empty list for empty stream"
'()
(stream->list (stream)))
(pass-if-equal "without count"
'(1 2 3)
(stream->list strm123))
(pass-if-equal "with count longer than stream"
'(1 2 3)
(stream->list 5 strm123))
(pass-if-equal "with count shorter than stream"
'(1 2 3)
(stream->list 3 (stream-from 1))))
(with-test-prefix "stream-append"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-append "four"))
(pass-if "with one stream"
(stream-equal? (stream-append strm123) strm123))
(pass-if "with two streams"
(stream-equal? (stream-append strm123 strm123) (stream 1 2 3 1 2 3)))
(pass-if "with three streams"
(stream-equal? (stream-append strm123 strm123 strm123)
(stream 1 2 3 1 2 3 1 2 3)))
(pass-if "append with null is noop"
(stream-equal? (stream-append strm123 stream-null) strm123))
(pass-if "prepend with null is noop"
(stream-equal? (stream-append stream-null strm123) strm123)))
(with-test-prefix "stream-concat"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-concat "four"))
(pass-if "with one stream"
(stream-equal? (stream-concat (stream strm123)) strm123))
(pass-if "with two streams"
(stream-equal? (stream-concat (stream strm123 strm123))
(stream 1 2 3 1 2 3))))
(with-test-prefix "stream-constant"
(pass-if "circular stream of 1 has >100 elements"
(eqv? (stream-ref (stream-constant 1) 100) 1))
(pass-if "circular stream of 2 has >100 elements"
(eqv? (stream-ref (stream-constant 1 2) 100) 1))
(pass-if "circular stream of 3 repeats after 3"
(eqv? (stream-ref (stream-constant 1 2 3) 3) 1))
(pass-if "circular stream of 1 repeats at 1"
(stream-equal? (stream-take 8 (stream-constant 1))
(stream 1 1 1 1 1 1 1 1)))
(pass-if "circular stream of 2 repeats at 2"
(stream-equal? (stream-take 8 (stream-constant 1 2))
(stream 1 2 1 2 1 2 1 2)))
(pass-if "circular stream of 3 repeats at 3"
(stream-equal? (stream-take 8 (stream-constant 1 2 3))
(stream 1 2 3 1 2 3 1 2))))
(with-test-prefix "stream-drop"
(pass-if-exception "throws for non-integer count"
'(wrong-type-arg . "non-integer argument")
(stream-drop "four" strm123))
(pass-if-exception "throws for negative count"
'(wrong-type-arg . "negative argument")
(stream-drop -1 strm123))
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-drop 2 "four"))
(pass-if "returns null when given null"
(stream-null? (stream-drop 0 stream-null)))
(pass-if "returns same stream when count is zero"
(eq? (stream-drop 0 strm123) strm123))
(pass-if "returns dropped-by-one stream when count is one"
(stream-equal? (stream-drop 1 strm123) (stream 2 3)))
(pass-if "returns null if count is longer than stream"
(stream-null? (stream-drop 5 strm123))))
(with-test-prefix "stream-drop-while"
(pass-if-exception "throws for invalid predicate"
'(wrong-type-arg . "non-procedural argument")
(stream-drop-while "four" strm123))
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-drop-while odd? "four"))
(pass-if "returns null when given null"
(stream-null? (stream-drop-while odd? stream-null)))
(pass-if "returns dropped stream when first element matches"
(stream-equal? (stream-drop-while odd? strm123) (stream 2 3)))
(pass-if "returns whole stream when first element doesn't match"
(stream-equal? (stream-drop-while even? strm123) strm123))
(pass-if "returns empty stream if all elements match"
(stream-null? (stream-drop-while positive? strm123)))
(pass-if "return whole stream if no elements match"
(stream-equal? (stream-drop-while negative? strm123) strm123)))
(with-test-prefix "stream-filter"
(pass-if-exception "throws for invalid predicate"
'(wrong-type-arg . "non-procedural argument")
(stream-filter "four" strm123))
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-filter odd? '()))
(pass-if "returns null when given null"
(stream-null? (stream-filter odd? (stream))))
(pass-if "filters out even numbers"
(stream-equal? (stream-filter odd? strm123) (stream 1 3)))
(pass-if "filters out odd numbers"
(stream-equal? (stream-filter even? strm123) (stream 2)))
(pass-if "returns all elements if predicate matches all"
(stream-equal? (stream-filter positive? strm123) strm123))
(pass-if "returns null if predicate matches none"
(stream-null? (stream-filter negative? strm123)))
(pass-if "all elements of an odd-filtered stream are odd"
(every odd? (stream->list 10 (stream-filter odd? (stream-from 0)))))
(pass-if "no elements of an odd-filtered stream are even"
(not (any even? (stream->list 10 (stream-filter odd? (stream-from 0)))))))
(with-test-prefix "stream-fold"
(pass-if-exception "throws for invalid function"
'(wrong-type-arg . "non-procedural argument")
(stream-fold "four" 0 strm123))
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-fold + 0 '()))
(pass-if "returns the correct result" (eqv? (stream-fold + 0 strm123) 6)))
(with-test-prefix "stream-for-each"
(pass-if-exception "throws for invalid function"
'(wrong-type-arg . "non-procedural argument")
(stream-for-each "four" strm123))
(pass-if-exception "throws if given no streams" exception:wrong-num-args
(stream-for-each display))
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-for-each display "four"))
(pass-if "function is called for stream elements"
(eqv? (let ((sum 0))
(stream-for-each (lambda (x)
(set! sum (+ sum x)))
strm123)
sum)
6)))
(with-test-prefix "stream-from"
(pass-if-exception "throws for non-numeric start"
'(wrong-type-arg . "non-numeric starting number")
(stream-from "four"))
(pass-if-exception "throws for non-numeric step"
'(wrong-type-arg . "non-numeric step size")
(stream-from 1 "four"))
(pass-if "works for default values"
(eqv? (stream-ref (stream-from 0) 100) 100))
(pass-if "works for non-default start and step"
(eqv? (stream-ref (stream-from 1 2) 100) 201))
(pass-if "works for negative step"
(eqv? (stream-ref (stream-from 0 -1) 100) -100)))
(with-test-prefix "stream-iterate"
(pass-if-exception "throws for invalid function"
'(wrong-type-arg . "non-procedural argument")
(stream-iterate "four" 0))
(pass-if "returns correct iterated stream with 1+"
(stream-equal? (stream-take 3 (stream-iterate 1+ 1)) strm123))
(pass-if "returns correct iterated stream with exact-integer-sqrt"
(stream-equal? (stream-take 5 (stream-iterate exact-integer-sqrt 65536))
(stream 65536 256 16 4 2))))
(with-test-prefix "stream-length"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-length "four"))
(pass-if "returns 0 for empty stream" (zero? (stream-length (stream))))
(pass-if "returns correct stream length" (eqv? (stream-length strm123) 3)))
(with-test-prefix "stream-let"
(pass-if "returns correct result"
(stream-equal?
(stream-let loop ((strm strm123))
(if (stream-null? strm)
stream-null
(stream-cons (* 2 (stream-car strm))
(loop (stream-cdr strm)))))
(stream 2 4 6))))
(with-test-prefix "stream-map"
(pass-if-exception "throws for invalid function"
'(wrong-type-arg . "non-procedural argument")
(stream-map "four" strm123))
(pass-if-exception "throws if given no streams" exception:wrong-num-args
(stream-map odd?))
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-map odd? "four"))
(pass-if "works for one stream"
(stream-equal? (stream-map - strm123) (stream -1 -2 -3)))
(pass-if "works for two streams"
(stream-equal? (stream-map + strm123 strm123) (stream 2 4 6)))
(pass-if "returns finite stream for finite first stream"
(stream-equal? (stream-map + strm123 (stream-from 1)) (stream 2 4 6)))
(pass-if "returns finite stream for finite last stream"
(stream-equal? (stream-map + (stream-from 1) strm123) (stream 2 4 6)))
(pass-if "works for three streams"
(stream-equal? (stream-map + strm123 strm123 strm123) (stream 3 6 9))))
(with-test-prefix "stream-match"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-match '(1 2 3) (_ 'ok)))
(pass-if-exception "throws when no pattern matches"
'(match-error . "no matching pattern")
(stream-match strm123 (() 42)))
(pass-if-equal "matches empty stream correctly"
'ok
(stream-match stream-null (() 'ok)))
(pass-if-equal "matches non-empty stream correctly"
'ok
(stream-match strm123 (() 'no) (else 'ok)))
(pass-if-equal "matches stream of one element"
1
(stream-match (stream 1) (() 'no) ((a) a)))
(pass-if-equal "matches wildcard"
'ok
(stream-match (stream 1) (() 'no) ((_) 'ok)))
(pass-if-equal "matches stream of three elements"
'(1 2 3)
(stream-match strm123 ((a b c) (list a b c))))
(pass-if-equal "matches first element with wildcard rest"
1
(stream-match strm123 ((a . _) a)))
(pass-if-equal "matches first two elements with wildcard rest"
'(1 2)
(stream-match strm123 ((a b . _) (list a b))))
(pass-if-equal "rest variable matches as stream"
'(1 2 3)
(stream-match strm123 ((a b . c) (list a b (stream-car c)))))
(pass-if-equal "rest variable can match whole stream"
'(1 2 3)
(stream-match strm123 (s (stream->list s))))
(pass-if-equal "successful guard match"
'ok
(stream-match strm123 ((a . _) (= a 1) 'ok)))
(pass-if-equal "unsuccessful guard match"
'no
(stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)))
(pass-if-equal "unsuccessful guard match with two variables"
'no
(stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)))
(pass-if-equal "successful guard match with two variables"
'yes
(stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no))))
(with-test-prefix "stream-of"
(pass-if "all 3 clause types work"
(stream-equal? (stream-of (+ y 6)
(x in (stream-range 1 6))
(odd? x)
(y is (* x x)))
(stream 7 15 31)))
(pass-if "using two streams creates cartesian product"
(stream-equal? (stream-of (* x y)
(x in (stream-range 1 4))
(y in (stream-range 1 5)))
(stream 1 2 3 4 2 4 6 8 3 6 9 12)))
(pass-if "using no clauses returns just the expression"
(stream-equal? (stream-of 1) (stream 1))))
(with-test-prefix "stream-range"
(pass-if-exception "throws for non-numeric start"
'(wrong-type-arg . "non-numeric starting number")
(stream-range "four" 0))
(pass-if-exception "throws for non-numeric end"
'(wrong-type-arg . "non-numeric ending number")
(stream-range 0 "four"))
(pass-if-exception "throws for non-numeric step"
'(wrong-type-arg . "non-numeric step size")
(stream-range 1 2 "three"))
(pass-if "returns increasing range if start < end"
(stream-equal? (stream-range 0 5) (stream 0 1 2 3 4)))
(pass-if "returns decreasing range if start > end"
(stream-equal? (stream-range 5 0) (stream 5 4 3 2 1)))
(pass-if "returns increasing range of step 2"
(stream-equal? (stream-range 0 5 2) (stream 0 2 4)))
(pass-if "returns decreasing range of step 2"
(stream-equal? (stream-range 5 0 -2) (stream 5 3 1)))
(pass-if "returns empty range if start is past end value"
(stream-null? (stream-range 0 1 -1))))
(with-test-prefix "stream-ref"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-ref '() 4))
(pass-if-exception "throws for non-integer index"
'(wrong-type-arg . "non-integer argument")
(stream-ref nats 3.5))
(pass-if-exception "throws for negative index"
'(wrong-type-arg . "negative argument")
(stream-ref nats -3))
(pass-if-exception "throws if index goes past end of stream"
'(wrong-type-arg . "beyond end of stream")
(stream-ref strm123 5))
(pass-if-equal "returns first element when index = 0"
1
(stream-ref nats 0))
(pass-if-equal "returns second element when index = 1"
2
(stream-ref nats 1))
(pass-if-equal "returns third element when index = 2"
3
(stream-ref nats 2)))
(with-test-prefix "stream-reverse"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-reverse '()))
(pass-if "returns null when given null"
(stream-null? (stream-reverse (stream))))
(pass-if "returns (3 2 1) for (1 2 3)"
(stream-equal? (stream-reverse strm123) (stream 3 2 1))))
(with-test-prefix "stream-scan"
(pass-if-exception "throws for invalid function"
'(wrong-type-arg . "non-procedural argument")
(stream-scan "four" 0 strm123))
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-scan + 0 '()))
(pass-if "returns the correct result"
(stream-equal? (stream-scan + 0 strm123) (stream 0 1 3 6))))
(with-test-prefix "stream-take"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-take 5 "four"))
(pass-if-exception "throws for non-integer index"
'(wrong-type-arg . "non-integer argument")
(stream-take "four" strm123))
(pass-if-exception "throws for negative index"
'(wrong-type-arg . "negative argument")
(stream-take -4 strm123))
(pass-if "returns null for empty stream"
(stream-null? (stream-take 5 stream-null)))
(pass-if "using 0 index returns null for empty stream"
(stream-null? (stream-take 0 stream-null)))
(pass-if "using 0 index returns null for non-empty stream"
(stream-null? (stream-take 0 strm123)))
(pass-if "returns first 2 elements of stream"
(stream-equal? (stream-take 2 strm123) (stream 1 2)))
(pass-if "returns whole stream when index is same as length"
(stream-equal? (stream-take 3 strm123) strm123))
(pass-if "returns whole stream when index exceeds length"
(stream-equal? (stream-take 5 strm123) strm123)))
(with-test-prefix "stream-take-while"
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-take-while odd? "four"))
(pass-if-exception "throws for invalid predicate"
'(wrong-type-arg . "non-procedural argument")
(stream-take-while "four" strm123))
(pass-if "returns stream up to first non-matching item"
(stream-equal? (stream-take-while odd? strm123) (stream 1)))
(pass-if "returns empty stream if first item doesn't match"
(stream-null? (stream-take-while even? strm123)))
(pass-if "returns whole stream if every item matches"
(stream-equal? (stream-take-while positive? strm123) strm123))
(pass-if "return empty stream if no item matches"
(stream-null? (stream-take-while negative? strm123))))
(with-test-prefix "stream-unfold"
(pass-if-exception "throws for invalid mapper"
'(wrong-type-arg . "non-procedural mapper")
(stream-unfold "four" odd? + 0))
(pass-if-exception "throws for invalid predicate"
'(wrong-type-arg . "non-procedural pred?")
(stream-unfold + "four" + 0))
(pass-if-exception "throws for invalid generator"
'(wrong-type-arg . "non-procedural generator")
(stream-unfold + odd? "four" 0))
(pass-if "returns the correct result"
(stream-equal? (stream-unfold (cut expt <> 2) (cut < <> 10) 1+ 0)
(stream 0 1 4 9 16 25 36 49 64 81))))
(with-test-prefix "stream-unfolds"
(pass-if "returns the correct result"
(stream-equal? (stream-unfolds
(lambda (x)
(receive (n s) (car+cdr x)
(if (zero? n)
(values 'dummy '())
(values
(cons (- n 1) (stream-cdr s))
(list (stream-car s))))))
(cons 5 (stream-from 0)))
(stream 0 1 2 3 4)))
(pass-if "handles returns of multiple elements correctly"
(stream-equal? (stream-take 16 (stream-unfolds
(lambda (n)
(values (1+ n) (iota n)))
1))
(stream 0 0 1 0 1 2 0 1 2 3 0 1 2 3 4 0)))
(receive (p np)
(stream-unfolds (lambda (x)
(receive (n p) (car+cdr x)
(if (= n (stream-car p))
(values (cons (1+ n) (stream-cdr p))
(list n) #f)
(values (cons (1+ n) p)
#f (list n)))))
(cons 1 primes))
(pass-if "returns first stream correctly"
(stream-equal? (stream-take 15 p)
(stream 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47)))
(pass-if "returns second stream correctly"
(stream-equal? (stream-take 15 np)
(stream 1 4 6 8 9 10 12 14 15 16 18 20 21 22 24)))))
(with-test-prefix "stream-zip"
(pass-if-exception "throws if given no streams" exception:wrong-num-args
(stream-zip))
(pass-if-exception "throws for non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-zip "four"))
(pass-if-exception "throws if any argument is non-stream"
'(wrong-type-arg . "non-stream argument")
(stream-zip strm123 "four"))
(pass-if "returns null when given null as any argument"
(stream-null? (stream-zip strm123 stream-null)))
(pass-if "returns single-element lists when given one stream"
(stream-equal? (stream-zip strm123) (stream '(1) '(2) '(3))))
(pass-if "returns double-element lists when given two streams"
(stream-equal? (stream-zip strm123 strm123)
(stream '(1 1) '(2 2) '(3 3))))
(pass-if "returns finite stream if at least one given stream is"
(stream-equal? (stream-zip strm123 (stream-from 1))
(stream '(1 1) '(2 2) '(3 3))))
(pass-if "returns triple-element lists when given three streams"
(stream-equal? (stream-zip strm123 strm123 strm123)
(stream '(1 1 1) '(2 2 2) '(3 3 3)))))
(with-test-prefix "other tests"
(pass-if-equal "returns biggest prime under 1000"
997
(stream-car
(stream-reverse (stream-take-while (cut < <> 1000) primes))))
(pass-if "quicksort returns same result as insertion sort"
(stream-equal? (qsort < (stream 3 1 5 2 4))
(isort < (stream 2 5 1 4 3))))
(pass-if "merge sort returns same result as insertion sort"
(stream-equal? (msort < (stream 3 1 5 2 4))
(isort < (stream 2 5 1 4 3))))
;; http://www.research.att.com/~njas/sequences/A051037
(pass-if-equal "returns 1000th Hamming number"
51200000
(stream-ref hamming 999)))