;;;; srfi-41-test.scm  -*- Scheme -*-

; 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.

(import scheme
  (chicken condition)
  type-errors
  streams
  (streams utils)
  (streams math)
  (streams queue))

;;;

;;section-combinators

(define (left-section fn . args) (lambda xs (apply fn (append args xs))))

;(append xs args) = (reverse (append (reverse args) (reverse xs)))
(define (right-section fn . args) (lambda xs (apply fn (append xs args))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; unit tests

(define (typerrtst locnam typnam argnam)
  (string-append
    locnam
    ": "
    (make-error-type-message typnam argnam)) )

(define *verbose* #f)

(define-syntax tester
  (syntax-rules ()
    ((tester expr result)
      (tester "" expr result) )
    ((tester descrip expr result)
      (let ((_descrip (string-append " " descrip)))
        ;(print "test" _descrip ":\t" 'expr " = " 'result)
        (let (
          (val
            (handle-exceptions exp
              ;with
              (string-append
                ;! there must be a 'location property !
                (symbol->string ((condition-property-accessor 'exn 'location) exp))
                ": "
                ((condition-property-accessor 'exn 'message) exp))
              ;for
              expr ) ) )
          (let (
            (ok? (equal? val result)) )
            (when (or *verbose* (not ok?))
              (newline)
              (write 'expr) (newline))
            (unless ok?
              (print "  --> Failed!"))
            (when (or *verbose* (not ok?))
              (display "expected: ") (write result) (newline)
              (display "returned: ") (write val) (newline) ) ) ) ) ) ) )

(define strm123 (stream 1 2 3))

; executing (unit-test) should produce no output
(define (unit-test)

  ; stream-null
  (tester (stream? stream-null) #t)
  (tester (stream-null? stream-null) #t)
  (tester (stream-pair? stream-null) #f)

  ; stream-cons
  (tester (stream? (stream-cons 1 stream-null)) #t)
  (tester (stream-null? (stream-cons 1 stream-null)) #f)
  (tester (stream-pair? (stream-cons 1 stream-null)) #t)

  ; stream?
  (tester (stream? stream-null) #t)
  (tester (stream? (stream-cons 1 stream-null)) #t)
  (tester (stream? "four") #f)

  ; stream-null?
  (tester (stream-null? stream-null) #t)
  (tester (stream-null? (stream-cons 1 stream-null)) #f)
  (tester (stream-null? "four") #f)

  ; stream-pair?
  (tester (stream-pair? stream-null) #f)
  (tester (stream-pair? (stream-cons 1 stream-null)) #t)
  (tester (stream-pair? "four") #f)

  ; stream-car
  (tester (stream-car "four") (typerrtst "stream-car" "stream" "stream"))
  (tester (stream-car stream-null) (typerrtst "stream-car" "stream-occupied" "stream"))
  (tester (stream-car strm123) 1)

  ; stream-cdr
  (tester (stream-cdr "four") (typerrtst "stream-cdr" "stream" "stream"))
  (tester (stream-cdr stream-null) (typerrtst "stream-cdr" "stream-occupied" "stream"))
  (tester (stream-car (stream-cdr strm123)) 2)

  ; stream-lambda
  (tester
    (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
  (tester
    (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
  (tester (list->stream "four") (typerrtst "list->stream" "list" "objects"))
  (tester (stream->list (list->stream '())) '())
  (tester (stream->list (list->stream '(1 2 3))) '(1 2 3))

  ; port->stream
  (let* ((p (open-input-file "streams.ss"))
         (s (port->stream p)))
    (tester (port->stream "four") (typerrtst "port->stream" "input-port" "port"))
    (tester (string=? (list->string (stream->list 11 s)) "; Copyright") #t)
    (close-input-port p))

  ; stream
  (tester (stream->list (stream)) '())
  (tester (stream->list (stream 1)) '(1))
  (tester (stream->list (stream 1 2 3)) '(1 2 3))

  ; stream->list
  (tester (stream->list '()) (typerrtst "stream->list" "stream" "stream"))
  (tester (stream->list "four" strm123) (typerrtst "stream->list" "natural-integer" "count"))
  (tester (stream->list -1 strm123) (typerrtst "stream->list" "natural-integer" "count"))
  (tester (stream->list (stream)) '())
  (tester (stream->list strm123) '(1 2 3))
  (tester (stream->list 5 strm123) '(1 2 3))
  (tester (stream->list 3 (stream-from 1)) '(1 2 3))

  ; stream-append
  (tester (stream-append "four") (typerrtst "stream-append" "stream" "stream"))
  (tester (stream->list (stream-append strm123)) '(1 2 3))
  (tester (stream->list (stream-append strm123 strm123)) '(1 2 3 1 2 3))
  (tester (stream->list (stream-append strm123 strm123 strm123)) '(1 2 3 1 2 3 1 2 3))
  (tester (stream->list (stream-append strm123 stream-null)) '(1 2 3))
  (tester (stream->list (stream-append stream-null strm123)) '(1 2 3))

  ; stream-concat
  (tester (stream-concat "four") (typerrtst "stream-concat" "stream" "stream"))
  (tester (stream->list (stream-concat (stream strm123))) '(1 2 3))
  (tester (stream->list (stream-concat (stream strm123 strm123))) '(1 2 3 1 2 3))

  ; stream-constant
  (tester (stream-ref (stream-constant 1) 100) 1)
  (tester (stream-ref (stream-constant 1 2) 100) 1)
  (tester (stream-ref (stream-constant 1 2 3) 3) 1)

  ; stream-drop
  (tester (stream-drop "four" strm123) (typerrtst "stream-drop" "natural-integer" "count"))
  (tester (stream-drop -1 strm123) (typerrtst "stream-drop" "natural-integer" "count"))
  (tester (stream-drop 2 "four") (typerrtst "stream-drop" "stream" "stream"))
  (tester (stream->list (stream-drop 0 stream-null)) '())
  (tester (stream->list (stream-drop 0 strm123)) '(1 2 3))
  (tester (stream->list (stream-drop 1 strm123)) '(2 3))
  (tester (stream->list (stream-drop 5 strm123)) '())

  ; stream-drop-while
  (tester (stream-drop-while "four" strm123) (typerrtst "stream-drop-while" "procedure" "predicate?"))
  (tester (stream-drop-while odd? "four") (typerrtst "stream-drop-while" "stream" "stream"))
  (tester (stream->list (stream-drop-while odd? stream-null)) '())
  (tester (stream->list (stream-drop-while odd? strm123)) '(2 3))
  (tester (stream->list (stream-drop-while even? strm123)) '(1 2 3))
  (tester (stream->list (stream-drop-while positive? strm123)) '())
  (tester (stream->list (stream-drop-while negative? strm123)) '(1 2 3))

  ; stream-filter
  (tester (stream-filter "four" strm123) (typerrtst "stream-filter" "procedure" "predicate?"))
  (tester (stream-filter odd? '()) (typerrtst "stream-filter" "stream" "stream"))
  (tester (stream-null? (stream-filter odd? (stream))) #t)
  (tester (stream->list (stream-filter odd? strm123)) '(1 3))
  (tester (stream->list (stream-filter even? strm123)) '(2))
  (tester (stream->list (stream-filter positive? strm123)) '(1 2 3))
  (tester (stream->list (stream-filter negative? strm123)) '())
  (let loop ((n 10))
    (tester (odd? (stream-ref (stream-filter odd? (stream-from 0)) n)) #t)
    (if (positive? n) (loop (- n 1))))
  (let loop ((n 10))
    (tester (even? (stream-ref (stream-filter odd? (stream-from 0)) n)) #f)
    (if (positive? n) (loop (- n 1))))

  ; stream-fold
  (tester (stream-fold "four" 0 strm123) (typerrtst "stream-fold" "procedure" "function"))
  (tester (stream-fold + 0 '()) (typerrtst "stream-fold" "stream" "stream"))
  (tester (stream-fold + 0 strm123) 6)

  ; stream-for-each
  (tester (stream-for-each "four" strm123) (typerrtst "stream-for-each" "procedure" "procedure"))
  (tester (stream-for-each display) "stream-for-each: no stream arguments")
  (tester (stream-for-each display "four") (typerrtst "stream-for-each" "stream" "stream"))
  (tester (let ((sum 0)) (stream-for-each (lambda (x) (set! sum (+ sum x))) strm123) sum) 6)

  ; stream-from
  (tester (stream-from "four") (typerrtst "stream-from" "number" "first"))
  (tester (stream-from 1 "four") (typerrtst "stream-from" "number" "delta"))
  (tester (stream-ref (stream-from 0) 100) 100)
  (tester (stream-ref (stream-from 1 2) 100) 201)
  (tester (stream-ref (stream-from 0 -1) 100) -100)

  ; stream-iterate
  (tester (stream-iterate "four" 0) (typerrtst "stream-iterate" "procedure" "function"))
  (tester (stream->list 3 (stream-iterate (left-section + 1) 1)) '(1 2 3))

  ; stream-length
  (tester (stream-length "four") (typerrtst "stream-length" "stream" "stream"))
  (tester (stream-length (stream)) 0)
  (tester (stream-length strm123) 3)

  ; stream-let
  (tester (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
  (tester (stream-map "four" strm123) (typerrtst "stream-map" "procedure" "function"))
  (tester (stream-map odd?) "stream-map: no stream arguments")
  (tester (stream-map odd? "four") (typerrtst "stream-map" "stream" "stream"))
  (tester (stream->list (stream-map - strm123)) '(-1 -2 -3))
  (tester (stream->list (stream-map + strm123 strm123)) '(2 4 6))
  (tester (stream->list (stream-map + strm123 (stream-from 1))) '(2 4 6))
  (tester (stream->list (stream-map + (stream-from 1) strm123)) '(2 4 6))
  (tester (stream->list (stream-map + strm123 strm123 strm123)) '(3 6 9))

  ; stream-match
  (tester (stream-match '(1 2 3) (_ 'ok)) (typerrtst "stream-match" "stream" "stream"))
  (tester (stream-match strm123 (() 42)) "stream-match: no matching pattern")
  (tester (stream-match stream-null (() 'ok)) 'ok)
  (tester (stream-match strm123 (() 'no) (else 'ok)) 'ok)
  (tester (stream-match (stream 1) (() 'no) ((a) a)) 1)
  (tester (stream-match (stream 1) (() 'no) ((_) 'ok)) 'ok)
  (tester (stream-match strm123 ((a b c) (list a b c))) '(1 2 3))
  (tester (stream-match strm123 ((a . _) a)) 1)
  (tester (stream-match strm123 ((a b . _) (list a b))) '(1 2))
  (tester (stream-match strm123 ((a b . c) (list a b (stream-car c)))) '(1 2 3))
  (tester (stream-match strm123 (s (stream->list s))) '(1 2 3))
  (tester (stream-match strm123 ((a . _) (= a 1) 'ok)) 'ok)
  (tester (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)) 'no)
  (tester (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)) 'no)
  (tester (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no)) 'yes)

  ; stream-of
  (tester (stream->list
            (stream-of (+ y 6)
              (x in (stream-range 1 6))
              (odd? x)
              (y is (* x x)))) '(7 15 31))
  (tester (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))
  (tester (stream-car (stream-of 1)) 1)

  ; stream-range
  (tester (stream-range "four" 0) (typerrtst "stream-range" "number" "first"))
  (tester (stream-range 0 "four") (typerrtst "stream-range" "number" "past"))
  (tester (stream-range 1 2 "three") (typerrtst "stream-range" "number" "delta"))
  (tester (stream->list (stream-range 0 5)) '(0 1 2 3 4))
  (tester (stream->list (stream-range 5 0)) '(5 4 3 2 1))
  (tester (stream->list (stream-range 0 5 2)) '(0 2 4))
  (tester (stream->list (stream-range 5 0 -2)) '(5 3 1))
  (tester (stream->list (stream-range 0 1 -1)) '())

  ; stream-ref
  (tester (stream-ref '() 4) (typerrtst "stream-ref" "stream" "stream"))
  (tester (stream-ref natural-numbers-stream 3.5) (typerrtst "stream-ref" "natural-integer" "index"))
  (tester (stream-ref natural-numbers-stream -3) (typerrtst "stream-ref" "natural-integer" "index"))
  (tester (stream-ref strm123 5) "stream-ref: beyond end of stream")
  (tester (stream-ref strm123 0) 1)
  (tester (stream-ref strm123 1) 2)
  (tester (stream-ref strm123 2) 3)

  ; stream-reverse
  (tester (stream-reverse '()) (typerrtst "stream-reverse" "stream" "stream"))
  (tester (stream->list (stream-reverse (stream))) '())
  (tester (stream->list (stream-reverse strm123)) '(3 2 1))

  ; stream-scan
  (tester (stream-scan "four" 0 strm123) (typerrtst "stream-scan" "procedure" "function"))
  (tester (stream-scan + 0 '()) (typerrtst "stream-scan" "stream" "stream"))
  (tester (stream->list (stream-scan + 0 strm123)) '(0 1 3 6))

  ; stream-take
  (tester (stream-take 5 "four") (typerrtst "stream-take" "stream" "stream"))
  (tester (stream-take "four" strm123) (typerrtst "stream-take" "natural-integer" "count"))
  (tester (stream-take -4 strm123) (typerrtst "stream-take" "natural-integer" "count"))
  (tester (stream->list (stream-take 5 stream-null)) '())
  (tester (stream->list (stream-take 0 stream-null)) '())
  (tester (stream->list (stream-take 0 strm123)) '())
  (tester (stream->list (stream-take 2 strm123)) '(1 2))
  (tester (stream->list (stream-take 3 strm123)) '(1 2 3))
  (tester (stream->list (stream-take 5 strm123)) '(1 2 3))

  ; stream-take-while
  (tester (stream-take-while odd? "four") (typerrtst "stream-take-while" "stream" "stream"))
  (tester (stream-take-while "four" strm123) (typerrtst "stream-take-while" "procedure" "predicate?"))
  (tester (stream->list (stream-take-while odd? strm123)) '(1))
  (tester (stream->list (stream-take-while even? strm123)) '())
  (tester (stream->list (stream-take-while positive? strm123)) '(1 2 3))
  (tester (stream->list (stream-take-while negative? strm123)) '())

  ; stream-unfold
  (tester (stream-unfold "four" odd? + 0) (typerrtst "stream-unfold" "procedure" "mapper"))
  (tester (stream-unfold + "four" + 0) (typerrtst "stream-unfold" "procedure" "predicate?"))
  (tester (stream-unfold + odd? "four" 0) (typerrtst "stream-unfold" "procedure" "generator"))
  (tester (stream->list (stream-unfold (right-section expt 2) (right-section < 10) (right-section + 1) 0))
          '(0 1 4 9 16 25 36 49 64 81))

  ; stream-unfolds
  (tester
    (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
  (tester (stream-zip) "stream-zip: no stream arguments")
  (tester (stream-zip "four") (typerrtst "stream-zip" "stream" "stream"))
  (tester (stream-zip strm123 "four") (typerrtst "stream-zip" "stream" "stream"))
  (tester (stream->list (stream-zip strm123 stream-null)) '())
  (tester (stream->list (stream-zip strm123)) '((1) (2) (3)))
  (tester (stream->list (stream-zip strm123 strm123)) '((1 1) (2 2) (3 3)))
  (tester (stream->list (stream-zip strm123 (stream-from 1))) '((1 1) (2 2) (3 3)))
  (tester (stream->list (stream-zip strm123 strm123 strm123)) '((1 1 1) (2 2 2) (3 3 3)))

  ; other tests
  (tester
    (stream-car
      (stream-reverse
        (stream-take-while
          (right-section < 1000)
          prime-numbers-stream)))
    997)

  (tester
      (equal?
        (stream->list (stream-quick-sort < (stream 3 1 5 2 4)))
        (stream->list (stream-insertion-sort < (stream 2 5 1 4 3))))
      #t)

  (tester
      (equal?
        (stream->list (stream-merge-sort < (stream 3 1 5 2 4)))
        (stream->list (stream-insertion-sort < (stream 2 5 1 4 3))))
      #t)

  (tester (stream-ref hamming-sequence-stream 999) 51200000)

)

(newline)
(display "Unit Test")
(if *verbose*
  (display ":")
  (display " - Please wait. No output means \"passed\"."))
(newline)
(time (unit-test))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; leak tests

(define-constant SIZE 1000000)

;;

(define (times3 n)
  (stream-ref
    (stream-filter
      (lambda (x)
        (zero? (modulo x n)))
      (stream-from 0))
    3))
(newline)
(print "Times3 Test - Please wait. No output means \"passed\".")
(time (times3 SIZE))

#| ;FIXME How is this supposed to work? there is no 'eager' bottom for stream-force!
;;

(define-stream (traverse s) (traverse (stream-cdr s)))

;;

(newline)
(print "Traverse Test - Please wait. No output means \"passed\".")
(time (stream-ref (traverse (stream-from 0)) SIZE))

;;

(newline)
(print "Traverse Test (with stream head held) - Please wait. No output means \"passed\".")
(define strm (traverse (stream-from 0)))
(time (stream-ref strm SIZE))
|#

; 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)) SIZE)

; ... even if something holds the head of the stream
; (define s (traverse (stream-from 0)))
; (stream-ref s SIZE)

; 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 SIZE)