; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; unit tests
(define-syntax assert
(syntax-rules ()
((assert expr result)
(if (not (equal? expr result))
(begin
(newline) (display "failed assertion:") (newline)
(display 'expr) (newline)
(display "expected: ") (display result) (newline)
(display "returned: ") (display expr) (newline))))
((assert descrip expr result)
(if (not (equal? expr result))
(begin
(newline) (display "failed assertion: ") (display descrip) (newline)
(display 'expr) (newline)
(display "expected: ") (display result) (newline)
(display "returned: ") (display ex?r) (newline))))))
(define strm123 (stream 1 2 3))
; uncomment next line only for testing
(define (error s x) (string-append (symbol->string s) ": " x))
; executing (unit-test) should produce no output
(define (unit-test)
; stream-null
(assert (stream? stream-null) #t)
(assert (stream-null? stream-null) #t)
(assert (stream-pair? stream-null) #f)
; stream-cons
(assert (stream? (stream-cons 1 stream-null)) #t)
(assert (stream-null? (stream-cons 1 stream-null)) #f)
(assert (stream-pair? (stream-cons 1 stream-null)) #t)
; stream?
(assert (stream? stream-null) #t)
(assert (stream? (stream-cons 1 stream-null)) #t)
(assert (stream? "four") #f)
; stream-null?
(assert (stream-null? stream-null) #t)
(assert (stream-null? (stream-cons 1 stream-null)) #f)
(assert (stream-null? "four") #f)
; stream-pair?
(assert (stream-pair? stream-null) #f)
(assert (stream-pair? (stream-cons 1 stream-null)) #t)
(assert (stream-pair? "four") #f)
; stream-car
(assert (stream-car "four") "stream-car: non-stream")
(assert (stream-car stream-null) "stream-car: null stream")
(assert (stream-car strm123) 1)
; stream-cdr
(assert (stream-cdr "four") "stream-cdr: non-stream")
(assert (stream-cdr stream-null) "stream-cdr: null stream")
(assert (stream-car (stream-cdr strm123)) 2)
; stream-lambda
(assert
(stream->list
(letrec ((double
(stream-lambda (strm)
(if (stream-null? strm)
stream-null
(stream-cons
(* 2 (stream-car strm))
(double (stream-cdr strm)))))))
(double strm123)))
'(2 4 6))
; define-stream
(assert
(stream->list
(let ()
(define-stream (double strm)
(if (stream-null? strm)
stream-null
(stream-cons
(* 2 (stream-car strm))
(double (stream-cdr strm)))))
(double strm123)))
'(2 4 6))
; list->stream
(assert (list->stream "four") "list->stream: non-list argument")
(assert (stream->list (list->stream '())) '())
(assert (stream->list (list->stream '(1 2 3))) '(1 2 3))
; port->stream
(let* ((p (open-input-file "streams.ss"))
(s (port->stream p)))
(assert (port->stream "four") "port->stream: non-input-port argument")
(assert (string=? (list->string (stream->list 11 s)) "; Copyright") #t)
(close-input-port p))
; stream
(assert (stream->list (stream)) '())
(assert (stream->list (stream 1)) '(1))
(assert (stream->list (stream 1 2 3)) '(1 2 3))
; stream->list
(assert (stream->list '()) "stream->list: non-stream argument")
(assert (stream->list "four" strm123) "stream->list: non-integer count")
(assert (stream->list -1 strm123) "stream->list: negative count")
(assert (stream->list (stream)) '())
(assert (stream->list strm123) '(1 2 3))
(assert (stream->list 5 strm123) '(1 2 3))
(assert (stream->list 3 (stream-from 1)) '(1 2 3))
; stream-append
(assert (stream-append "four") "stream-append: non-stream argument")
(assert (stream->list (stream-append strm123)) '(1 2 3))
(assert (stream->list (stream-append strm123 strm123)) '(1 2 3 1 2 3))
(assert (stream->list (stream-append strm123 strm123 strm123)) '(1 2 3 1 2 3 1 2 3))
(assert (stream->list (stream-append strm123 stream-null)) '(1 2 3))
(assert (stream->list (stream-append stream-null strm123)) '(1 2 3))
; stream-concat
(assert (stream-concat "four") "stream-concat: non-stream argument")
(assert (stream->list (stream-concat (stream strm123))) '(1 2 3))
(assert (stream->list (stream-concat (stream strm123 strm123))) '(1 2 3 1 2 3))
; stream-constant
(assert (stream-ref (stream-constant 1) 100) 1)
(assert (stream-ref (stream-constant 1 2) 100) 1)
(assert (stream-ref (stream-constant 1 2 3) 3) 1)
; stream-drop
(assert (stream-drop "four" strm123) "stream-drop: non-integer argument")
(assert (stream-drop -1 strm123) "stream-drop: negative argument")
(assert (stream-drop 2 "four") "stream-drop: non-stream argument")
(assert (stream->list (stream-drop 0 stream-null)) '())
(assert (stream->list (stream-drop 0 strm123)) '(1 2 3))
(assert (stream->list (stream-drop 1 strm123)) '(2 3))
(assert (stream->list (stream-drop 5 strm123)) '())
; stream-drop-while
(assert (stream-drop-while "four" strm123) "stream-drop-while: non-procedural argument")
(assert (stream-drop-while odd? "four") "stream-drop-while: non-stream argument")
(assert (stream->list (stream-drop-while odd? stream-null)) '())
(assert (stream->list (stream-drop-while odd? strm123)) '(2 3))
(assert (stream->list (stream-drop-while even? strm123)) '(1 2 3))
(assert (stream->list (stream-drop-while positive? strm123)) '())
(assert (stream->list (stream-drop-while negative? strm123)) '(1 2 3))
; stream-filter
(assert (stream-filter "four" strm123) "stream-filter: non-procedural argument")
(assert (stream-filter odd? '()) "stream-filter: non-stream argument")
(assert (stream-null? (stream-filter odd? (stream))) #t)
(assert (stream->list (stream-filter odd? strm123)) '(1 3))
(assert (stream->list (stream-filter even? strm123)) '(2))
(assert (stream->list (stream-filter positive? strm123)) '(1 2 3))
(assert (stream->list (stream-filter negative? strm123)) '())
(let loop ((n 10))
(assert (odd? (stream-ref (stream-filter odd? (stream-from 0)) n)) #t)
(if (positive? n) (loop (- n 1))))
(let loop ((n 10))
(assert (even? (stream-ref (stream-filter odd? (stream-from 0)) n)) #f)
(if (positive? n) (loop (- n 1))))
; stream-fold
(assert (stream-fold "four" 0 strm123) "stream-fold: non-procedural argument")
(assert (stream-fold + 0 '()) "stream-fold: non-stream argument")
(assert (stream-fold + 0 strm123) 6)
; stream-for-each
(assert (stream-for-each "four" strm123) "stream-for-each: non-procedural argument")
(assert (stream-for-each display) "stream-for-each: no stream arguments")
(assert (stream-for-each display "four") "stream-for-each: non-stream argument")
(assert (let ((sum 0)) (stream-for-each (lambda (x) (set! sum (+ sum x))) strm123) sum) 6)
; stream-from
(assert (stream-from "four") "stream-from: non-numeric starting number")
(assert (stream-from 1 "four") "stream-from: non-numeric step size")
(assert (stream-ref (stream-from 0) 100) 100)
(assert (stream-ref (stream-from 1 2) 100) 201)
(assert (stream-ref (stream-from 0 -1) 100) -100)
; stream-iterate
(assert (stream-iterate "four" 0) "stream-iterate: non-procedural argument")
(assert (stream->list 3 (stream-iterate (lsec + 1) 1)) '(1 2 3))
; stream-length
(assert (stream-length "four") "stream-length: non-stream argument")
(assert (stream-length (stream)) 0)
(assert (stream-length strm123) 3)
; stream-let
(assert (stream->list
(stream-let loop ((strm strm123))
(if (stream-null? strm)
stream-null
(stream-cons
(* 2 (stream-car strm))
(loop (stream-cdr strm))))))
'(2 4 6))
; stream-map
(assert (stream-map "four" strm123) "stream-map: non-procedural argument")
(assert (stream-map odd?) "stream-map: no stream arguments")
(assert (stream-map odd? "four") "stream-map: non-stream argument")
(assert (stream->list (stream-map - strm123)) '(-1 -2 -3))
(assert (stream->list (stream-map + strm123 strm123)) '(2 4 6))
(assert (stream->list (stream-map + strm123 (stream-from 1))) '(2 4 6))
(assert (stream->list (stream-map + (stream-from 1) strm123)) '(2 4 6))
(assert (stream->list (stream-map + strm123 strm123 strm123)) '(3 6 9))
; stream-match
(assert (stream-match '(1 2 3) (_ 'ok)) "stream-match: non-stream argument")
(assert (stream-match strm123 (() 42)) "stream-match: pattern failure")
(assert (stream-match stream-null (() 'ok)) 'ok)
(assert (stream-match strm123 (() 'no) (else 'ok)) 'ok)
(assert (stream-match (stream 1) (() 'no) ((a) a)) 1)
(assert (stream-match (stream 1) (() 'no) ((_) 'ok)) 'ok)
(assert (stream-match strm123 ((a b c) (list a b c))) '(1 2 3))
(assert (stream-match strm123 ((a . _) a)) 1)
(assert (stream-match strm123 ((a b . _) (list a b))) '(1 2))
(assert (stream-match strm123 ((a b . c) (list a b (stream-car c)))) '(1 2 3))
(assert (stream-match strm123 (s (stream->list s))) '(1 2 3))
(assert (stream-match strm123 ((a . _) (= a 1) 'ok)) 'ok)
(assert (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)) 'no)
(assert (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)) 'no)
(assert (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no)) 'yes)
; stream-of
(assert (stream->list
(stream-of (+ y 6)
(x in (stream-range 1 6))
(odd? x)
(y is (* x x)))) '(7 15 31))
(assert (stream->list
(stream-of (* x y)
(x in (stream-range 1 4))
(y in (stream-range 1 5))))
'(1 2 3 4 2 4 6 8 3 6 9 12))
(assert (stream-car (stream-of 1)) 1)
; stream-range
(assert (stream-range "four" 0) "stream-range: non-numeric starting number")
(assert (stream-range 0 "four") "stream-range: non-numeric ending number")
(assert (stream-range 1 2 "three") "stream-range: non-numeric step size")
(assert (stream->list (stream-range 0 5)) '(0 1 2 3 4))
(assert (stream->list (stream-range 5 0)) '(5 4 3 2 1))
(assert (stream->list (stream-range 0 5 2)) '(0 2 4))
(assert (stream->list (stream-range 5 0 -2)) '(5 3 1))
(assert (stream->list (stream-range 0 1 -1)) '())
; stream-ref
(assert (stream-ref '() 4) "stream-ref: non-stream argument")
(assert (stream-ref nats 3.5) "stream-ref: non-integer argument")
(assert (stream-ref nats -3) "stream-ref: negative argument")
(assert (stream-ref strm123 5) "stream-ref: beyond end of stream")
(assert (stream-ref strm123 0) 1)
(assert (stream-ref strm123 1) 2)
(assert (stream-ref strm123 2) 3)
; stream-reverse
(assert (stream-reverse '()) "stream-reverse: non-stream argument")
(assert (stream->list (stream-reverse (stream))) '())
(assert (stream->list (stream-reverse strm123)) '(3 2 1))
; stream-scan
(assert (stream-scan "four" 0 strm123) "stream-scan: non-procedural argument")
(assert (stream-scan + 0 '()) "stream-scan: non-stream argument")
(assert (stream->list (stream-scan + 0 strm123)) '(0 1 3 6))
; stream-take
(assert (stream-take 5 "four") "stream-take: non-stream argument")
(assert (stream-take "four" strm123) "stream-take: non-integer argument")
(assert (stream-take -4 strm123) "stream-take: negative argument")
(assert (stream->list (stream-take 5 stream-null)) '())
(assert (stream->list (stream-take 0 stream-null)) '())
(assert (stream->list (stream-take 0 strm123)) '())
(assert (stream->list (stream-take 2 strm123)) '(1 2))
(assert (stream->list (stream-take 3 strm123)) '(1 2 3))
(assert (stream->list (stream-take 5 strm123)) '(1 2 3))
; stream-take-while
(assert (stream-take-while odd? "four") "stream-take-while: non-stream argument")
(assert (stream-take-while "four" strm123) "stream-take-while: non-procedural argument")
(assert (stream->list (stream-take-while odd? strm123)) '(1))
(assert (stream->list (stream-take-while even? strm123)) '())
(assert (stream->list (stream-take-while positive? strm123)) '(1 2 3))
(assert (stream->list (stream-take-while negative? strm123)) '())
; stream-unfold
(assert (stream-unfold "four" odd? + 0) "stream-unfold: non-procedural mapper")
(assert (stream-unfold + "four" + 0) "stream-unfold: non-procedural pred?")
(assert (stream-unfold + odd? "four" 0) "stream-unfold: non-procedural generator")
(assert (stream->list (stream-unfold (rsec expt 2) (rsec < 10) (rsec + 1) 0))
'(0 1 4 9 16 25 36 49 64 81))
; stream-unfolds
(assert
(stream->list
(stream-unfolds
(lambda (x)
(let ((n (car x)) (s (cdr x)))
(if (zero? n)
(values 'dummy '())
(values
(cons (- n 1) (stream-cdr s))
(list (stream-car s))))))
(cons 5 (stream-from 0))))
'(0 1 2 3 4))
; stream-zip
(assert (stream-zip) "stream-zip: no stream arguments")
(assert (stream-zip "four") "stream-zip: non-stream argument")
(assert (stream-zip strm123 "four") "stream-zip: non-stream argument")
(assert (stream->list (stream-zip strm123 stream-null)) '())
(assert (stream->list (stream-zip strm123)) '((1) (2) (3)))
(assert (stream->list (stream-zip strm123 strm123)) '((1 1) (2 2) (3 3)))
(assert (stream->list (stream-zip strm123 (stream-from 1))) '((1 1) (2 2) (3 3)))
(assert (stream->list (stream-zip strm123 strm123 strm123)) '((1 1 1) (2 2 2) (3 3 3)))
; other tests
(assert
(stream-car
(stream-reverse
(stream-take-while
(rsec < 1000)
primes)))
997)
(assert
(equal?
(stream->list (qsort < (stream 3 1 5 2 4)))
(stream->list (isort < (stream 2 5 1 4 3))))
#t)
(assert
(equal?
(stream->list (msort < (stream 3 1 5 2 4)))
(stream->list (isort < (stream 2 5 1 4 3))))
#t)
; http://www.research.att.com/~njas/sequences/A051037
(assert (stream-ref hamming 999) 51200000)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; leak tests
; These tests can't be automated with portable code, so they need to be run by hand.
; Thus, they have been commented out. To run the tests, uncomment them one by one,
; load them into a running Scheme system, and monitor space consumption using some
; os-specific tool outside the Scheme system. All should run in bounded space.
; traversing a stream should take bounded space ...
; (define-stream (traverse s) (traverse (stream-cdr s)))
; (stream-ref (traverse (stream-from 0)) 10000000)
; ... even if something holds the head of the stream
; (define s (traverse (stream-from 0)))
; (stream-ref s 10000000)
; the infamous times3 test from SRFI-40
; (define (times3 n)
; (stream-ref
; (stream-filter
; (lambda (x)
; (zero? (modulo x n)))
; (stream-from 0))
; 3))
; (times3 10000000)
Programming Praxis 