From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Add SRFI-41 Date: Wed, 20 Mar 2013 20:38:49 -0400 Message-ID: <87li9hbn8m.fsf@tines.lan> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1363826387 10729 80.91.229.3 (21 Mar 2013 00:39:47 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 21 Mar 2013 00:39:47 +0000 (UTC) Cc: "Chris K. Jester-Young" To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Thu Mar 21 01:40:11 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1UITYA-0002qo-Vp for guile-devel@m.gmane.org; Thu, 21 Mar 2013 01:40:11 +0100 Original-Received: from localhost ([::1]:44460 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UITXn-0005Ux-Nj for guile-devel@m.gmane.org; Wed, 20 Mar 2013 20:39:47 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:38519) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UITXd-0005Tc-BR for guile-devel@gnu.org; Wed, 20 Mar 2013 20:39:42 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UITXX-0002n1-L9 for guile-devel@gnu.org; Wed, 20 Mar 2013 20:39:37 -0400 Original-Received: from world.peace.net ([96.39.62.75]:43419) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UITXX-0002mm-AK for guile-devel@gnu.org; Wed, 20 Mar 2013 20:39:31 -0400 Original-Received: from 209-6-91-212.c3-0.smr-ubr1.sbo-smr.ma.cable.rcn.com ([209.6.91.212] helo=tines.lan) by world.peace.net with esmtpsa (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.72) (envelope-from ) id 1UITWy-0001Q5-QJ; Wed, 20 Mar 2013 20:38:58 -0400 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 96.39.62.75 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:15939 Archived-At: --=-=-= Content-Type: text/plain 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 :) --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-Add-SRFI-41.patch Content-Transfer-Encoding: quoted-printable Content-Description: [PATCH] Add SRFI-41 >From 6d05076bdc88e6d5be479a9446120c6c62fe6f60 Mon Sep 17 00:00:00 2001 From: "Chris K. Jester-Young" Date: Wed, 20 Mar 2013 20:14:18 -0400 Subject: [PATCH] Add SRFI-41. Incorporates suggestions from Mark H Weaver and Ian Price . * 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 =3D \ 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: . So for now, we duplicate the +;; code. + +;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2003 Andr=C3=A9 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-promis= e? + (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 (stre= am-promise-val promise*))) + (stream-value-proc-set! content + (stream-value-proc (st= ream-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 st= ream") + (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)))) str= m))) + +(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?) + (=3D stream-car var) + (=3D 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 (=3D> 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 =3D 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 =3D + (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 st= ream-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-n= ull))) + (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-fr= om 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-sqr= t 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 . _) (=3D a 1) 'ok)) 'ok)) + (pass-if "unsuccessful guard match" + (eq? (stream-match strm123 ((a . _) (=3D a 2) 'yes) (_ 'no)) 'n= o)) + (pass-if "unsuccessful guard match with two variables" + (eq? (stream-match strm123 ((a b c) (=3D a b) 'yes) (_ 'no)) 'n= o)) + (pass-if "successful guard match with two variables" + (eq? (stream-match (stream 1 1 2) ((a b c) (=3D 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 =3D 0" + (eqv? (stream-ref nats 0) 1)) + (pass-if "returns second element when index =3D 1" + (eqv? (stream-ref nats 1) 2)) + (pass-if "returns third element when index =3D 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 (=3D 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 2= 4))))) + +(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) prime= s))) + 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))) --=20 1.7.10.4 --=-=-=--