[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Add SRFI-41
|
From: |
Mark H Weaver |
|
Subject: |
[PATCH] Add SRFI-41 |
|
Date: |
Wed, 20 Mar 2013 20:38:49 -0400 |
Hello all,
Chris K. Jester-Young has been hard at work getting his SRFI-41
implementation ready in time for Guile 2.0.8, and I think it might be
ready to push. What do you think?
Reviews solicited.
Mark
PS: Although I put cky's name on this commit (he's certainly the primary
author), I made some tweaks to it since he last looked at it which
he may or may not approve of :)
>From 6d05076bdc88e6d5be479a9446120c6c62fe6f60 Mon Sep 17 00:00:00 2001
From: "Chris K. Jester-Young" <address@hidden>
Date: Wed, 20 Mar 2013 20:14:18 -0400
Subject: [PATCH] Add SRFI-41.
Incorporates suggestions from Mark H Weaver <address@hidden>
and Ian Price <address@hidden>.
* 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.
---
module/Makefile.am | 1 +
module/srfi/srfi-41.scm | 478 ++++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-41.test | 657 +++++++++++++++++++++++++++++++++++++++++
4 files changed, 1137 insertions(+)
create mode 100644 module/srfi/srfi-41.scm
create mode 100644 test-suite/tests/srfi-41.test
diff --git a/module/Makefile.am b/module/Makefile.am
index c47d0b4..416ad22 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -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 \
diff --git a/module/srfi/srfi-41.scm b/module/srfi/srfi-41.scm
new file mode 100644
index 0000000..16596ce
--- /dev/null
+++ b/module/srfi/srfi-41.scm
@@ -0,0 +1,478 @@
+;;; 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))
+
+;;; 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, 2013 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 . xs)
+ (make-stream-promise (make-stream-value 'eager xs)))
+
+(define-syntax-rule (stream-delay exp)
+ (stream-lazy (call-with-values
+ (lambda () exp)
+ stream-eager)))
+
+(define (stream-force promise)
+ (let ((content (stream-promise-val promise)))
+ (case (stream-value-tag content)
+ ((eager) (apply values (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-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-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-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-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)))))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index e7c8c41..01ffd1c 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -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 \
diff --git a/test-suite/tests/srfi-41.test b/test-suite/tests/srfi-41.test
new file mode 100644
index 0000000..f7420a9
--- /dev/null
+++ b/test-suite/tests/srfi-41.test
@@ -0,0 +1,657 @@
+;;; 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 "reads input string correctly"
+ (equal? (list->string (stream->list (port->stream p)))
+ "Hello, world!")))))
+
+(with-test-prefix "stream"
+ (pass-if "with empty stream"
+ (equal? (stream->list (stream)) '()))
+ (pass-if "with one-element stream"
+ (equal? (stream->list (stream 1)) '(1)))
+ (pass-if "with three-element stream"
+ (equal? (stream->list (stream 1 2 3)) '(1 2 3))))
+
+(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 "returns empty list for empty stream"
+ (eq? (stream->list (stream)) '()))
+ (pass-if "without count"
+ (equal? (stream->list strm123) '(1 2 3)))
+ (pass-if "with count longer than stream"
+ (equal? (stream->list 5 strm123) '(1 2 3)))
+ (pass-if "with count shorter than stream"
+ (equal? (stream->list 3 (stream-from 1)) '(1 2 3))))
+
+(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 "matches empty stream correctly"
+ (eq? (stream-match stream-null (() 'ok)) 'ok))
+ (pass-if "matches non-empty stream correctly"
+ (eq? (stream-match strm123 (() 'no) (else 'ok)) 'ok))
+ (pass-if "matches stream of one element"
+ (eqv? (stream-match (stream 1) (() 'no) ((a) a)) 1))
+ (pass-if "matches wildcard"
+ (eq? (stream-match (stream 1) (() 'no) ((_) 'ok)) 'ok))
+ (pass-if "matches stream of three elements"
+ (equal? (stream-match strm123 ((a b c) (list a b c))) '(1 2 3)))
+ (pass-if "matches first element with wildcard rest"
+ (eqv? (stream-match strm123 ((a . _) a)) 1))
+ (pass-if "matches first two elements with wildcard rest"
+ (equal? (stream-match strm123 ((a b . _) (list a b))) '(1 2)))
+ (pass-if "rest variable matches as stream"
+ (equal? (stream-match strm123 ((a b . c) (list a b (stream-car c))))
+ '(1 2 3)))
+ (pass-if "rest variable can match whole stream"
+ (equal? (stream-match strm123 (s (stream->list s))) '(1 2 3)))
+ (pass-if "successful guard match"
+ (eq? (stream-match strm123 ((a . _) (= a 1) 'ok)) 'ok))
+ (pass-if "unsuccessful guard match"
+ (eq? (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)) 'no))
+ (pass-if "unsuccessful guard match with two variables"
+ (eq? (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)) 'no))
+ (pass-if "successful guard match with two variables"
+ (eq? (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no))
'yes)))
+
+(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 "returns first element when index = 0"
+ (eqv? (stream-ref nats 0) 1))
+ (pass-if "returns second element when index = 1"
+ (eqv? (stream-ref nats 1) 2))
+ (pass-if "returns third element when index = 2"
+ (eqv? (stream-ref nats 2) 3)))
+
+(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 "returns biggest prime under 1000"
+ (eqv? (stream-car
+ (stream-reverse (stream-take-while (cut < <> 1000) primes)))
+ 997))
+
+ (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 "returns 1000th Hamming number"
+ (eqv? (stream-ref hamming 999) 51200000)))
--
1.7.10.4
- [PATCH] Add SRFI-41,
Mark H Weaver <=