;; ----------------------------------------------------------------------
;;  SRFI 41 ...
;; ----------------------------------------------------------------------
;(test-subsection "SRFI 41 - Streams")

;(require "srfi-41")

;; wrapper for srfi-41-test-assert:
(define-macro (srfi-41-test-assert expr result)
  (let ((name (symbol->string (gensym "srfi-41-"))))
    `(test ,name ,result ,expr)))

(define strm123
  (stream-cons
   1 (stream-cons
      2 (stream-cons
         3 stream-null))))

(define %old-error error)
(define (error where what)
  (with-output-to-string
    (lambda ()
      (display where)
      (display ": ")
      (display what))))

(define (identity obj) obj)

(define (const obj) (lambda x obj))

(define (negate pred?) (lambda (x) (not (pred? x))))

(define (lsec proc . args) (lambda x (apply proc (append args x))))

(define (rsec proc . args) (lambda x (apply proc (reverse (append (reverse args) (reverse x))))))

(define nats
  (stream-cons 0
    (stream-map add1 nats)))

(define (compose . fns)
  (let comp ((fns fns))
    (cond
      ((null? fns) 'error)
      ((null? (cdr fns)) (car fns))
      (else
        (lambda args
          (call-with-values
            (lambda ()
              (apply
                (comp (cdr fns))
                args))
            (car fns)))))))

(define-stream (stream-unique eql? strm)
  (if (stream-null? strm)
      stream-null
      (stream-cons (stream-car strm)
        (stream-unique eql?
          (stream-drop-while
            (lambda (x)
              (eql? (stream-car strm) x))
            strm)))))

(define-stream (stream-merge lt? . strms)
  (define-stream (merge xx yy)
    (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))))))))
  (stream-let loop ((strms strms))
    (cond ((null? strms) stream-null)
          ((null? (cdr strms)) (car strms))
          (else (merge (car strms)
                       (apply stream-merge lt?
                         (cdr strms)))))))

(define (insert a)
  (stream-lambda (xs ys)
    (stream-append xs (stream a) ys)))


(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 (qsort lt? strm)
  (if (stream-null? strm)
      stream-null
      (let ((x (stream-car strm))
            (xs (stream-cdr strm)))
        (stream-append
          (qsort lt?
            (stream-filter
              (lambda (u) (lt? u x))
              xs))
          (stream x)
          (qsort lt?
            (stream-filter
              (lambda (u) (not (lt? u 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 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))
  (define-stream (sieve strm)
    (let ((first (stream-car strm))
          (rest (stream-cdr strm)))
      (stream-cons first
        (sieve (sift first rest)))))
  (sieve (stream-from 2))))

(define hamming
  (stream-unique =
    (stream-cons 1
      (stream-merge <
        (stream-map (lsec * 2) hamming)
        (stream-merge <
          (stream-map (lsec * 3) hamming)
          (stream-map (lsec * 5) hamming))))))

  ; stream-null
  (srfi-41-test-assert (stream? stream-null) #t)
  (srfi-41-test-assert (stream-null? stream-null) #t)
  (srfi-41-test-assert (stream-pair? stream-null) #f)

  ; stream-cons
  (srfi-41-test-assert (stream? (stream-cons 1 stream-null)) #t)
  (srfi-41-test-assert (stream-null? (stream-cons 1 stream-null)) #f)
  (srfi-41-test-assert (stream-pair? (stream-cons 1 stream-null)) #t)

  ; stream?
  (srfi-41-test-assert (stream? stream-null) #t)
  (srfi-41-test-assert (stream? (stream-cons 1 stream-null)) #t)
  (srfi-41-test-assert (stream? "four") #f)

  ; stream-null?
  (srfi-41-test-assert (stream-null? stream-null) #t)
  (srfi-41-test-assert (stream-null? (stream-cons 1 stream-null)) #f)
  (srfi-41-test-assert (stream-null? "four") #f)

  ; stream-pair?
  (srfi-41-test-assert (stream-pair? stream-null) #f)
  (srfi-41-test-assert (stream-pair? (stream-cons 1 stream-null)) #t)
  (srfi-41-test-assert (stream-pair? "four") #f)

  ; stream-car
  (srfi-41-test-assert (stream-car "four") "stream-car: non-stream")
  (srfi-41-test-assert (stream-car stream-null) "stream-car: null stream")
  (srfi-41-test-assert (stream-car strm123) 1)

  ; stream-cdr
  (srfi-41-test-assert (stream-cdr "four") "stream-cdr: non-stream")
  (srfi-41-test-assert (stream-cdr stream-null) "stream-cdr: null stream")
  (srfi-41-test-assert (stream-car (stream-cdr strm123)) 2)

  ; stream-lambda
  (srfi-41-test-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
  (srfi-41-test-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
  (srfi-41-test-assert (list->stream "four") "list->stream: non-list argument")
  (srfi-41-test-assert (stream->list (list->stream '())) '())
  (srfi-41-test-assert (stream->list (list->stream '(1 2 3))) '(1 2 3))

  ;; ; port->stream
  ;; ;; (let* ((p (open-input-file "streams.ss"))
  ;; ;;        (s (port->stream p)))
  ;; ;;   (srfi-41-test-assert (port->stream "four") "port->stream: non-input-port argument")
  ;; ;;   (srfi-41-test-assert (string=? (list->string (stream->list 11 s)) "; Copyright") #t)
  ;; ;;   (close-input-port p))

  ; stream
  (srfi-41-test-assert (stream->list (stream)) '())
  (srfi-41-test-assert (stream->list (stream 1)) '(1))
  (srfi-41-test-assert (stream->list (stream 1 2 3)) '(1 2 3))

  ;; ; stream->list
  (srfi-41-test-assert (stream->list '()) "stream->list: non-stream argument")
  (srfi-41-test-assert (stream->list "four" strm123) "stream->list: non-integer count")
  (srfi-41-test-assert (stream->list -1 strm123) "stream->list: negative count")
  (srfi-41-test-assert (stream->list (stream)) '())
  (srfi-41-test-assert (stream->list strm123) '(1 2 3))
  (srfi-41-test-assert (stream->list 5 strm123) '(1 2 3))
  (srfi-41-test-assert (stream->list 3 (stream-from 1)) '(1 2 3))

  ; stream-append
  (srfi-41-test-assert (stream-append "four") "stream-append: non-stream argument")

  (srfi-41-test-assert (stream->list (stream-append strm123)) '(1 2 3))
  (srfi-41-test-assert (stream->list (stream-append strm123 strm123)) '(1 2 3 1 2 3))
  (srfi-41-test-assert (stream->list (stream-append strm123 strm123 strm123)) '(1 2 3 1 2 3 1 2 3))
  (srfi-41-test-assert (stream->list (stream-append strm123 stream-null)) '(1 2 3))
  (srfi-41-test-assert (stream->list (stream-append stream-null strm123)) '(1 2 3))


  ; stream-concat
  (srfi-41-test-assert (stream-concat "four") "stream-concat: non-stream argument")
  (srfi-41-test-assert (stream->list (stream-concat (stream strm123))) '(1 2 3))
  (srfi-41-test-assert (stream->list (stream-concat (stream strm123 strm123))) '(1 2 3 1 2 3))

  ; stream-constant
  (srfi-41-test-assert (stream-ref (stream-constant 1) 100) 1)
  (srfi-41-test-assert (stream-ref (stream-constant 1 2) 100) 1)
  (srfi-41-test-assert (stream-ref (stream-constant 1 2 3) 3) 1)

  ; stream-drop
  (srfi-41-test-assert (stream-drop "four" strm123) "stream-drop: non-integer argument")
  (srfi-41-test-assert (stream-drop -1 strm123) "stream-drop: negative argument")
  (srfi-41-test-assert (stream-drop 2 "four") "stream-drop: non-stream argument")
  (srfi-41-test-assert (stream->list (stream-drop 0 stream-null)) '())
  (srfi-41-test-assert (stream->list (stream-drop 0 strm123)) '(1 2 3))
  (srfi-41-test-assert (stream->list (stream-drop 1 strm123)) '(2 3))
  (srfi-41-test-assert (stream->list (stream-drop 5 strm123)) '())

  ; stream-drop-while
  (srfi-41-test-assert (stream-drop-while "four" strm123) "stream-drop-while: non-procedural argument")
  (srfi-41-test-assert (stream-drop-while odd? "four") "stream-drop-while: non-stream argument")
  (srfi-41-test-assert (stream->list (stream-drop-while odd? stream-null)) '())
  (srfi-41-test-assert (stream->list (stream-drop-while odd? strm123)) '(2 3))
  (srfi-41-test-assert (stream->list (stream-drop-while even? strm123)) '(1 2 3))
  (srfi-41-test-assert (stream->list (stream-drop-while positive? strm123)) '())
  (srfi-41-test-assert (stream->list (stream-drop-while negative? strm123)) '(1 2 3))

  ; stream-filter
  (srfi-41-test-assert (stream-filter "four" strm123) "stream-filter: non-procedural argument")
  (srfi-41-test-assert (stream-filter odd? '()) "stream-filter: non-stream argument")
  (srfi-41-test-assert (stream-null? (stream-filter odd? (stream))) #t)
  (srfi-41-test-assert (stream->list (stream-filter odd? strm123)) '(1 3))
  (srfi-41-test-assert (stream->list (stream-filter even? strm123)) '(2))
  (srfi-41-test-assert (stream->list (stream-filter positive? strm123)) '(1 2 3))
  (srfi-41-test-assert (stream->list (stream-filter negative? strm123)) '())
  (let loop ((n 10))
    (srfi-41-test-assert (odd? (stream-ref (stream-filter odd? (stream-from 0)) n)) #t)
    (if (positive? n) (loop (- n 1))))
  (let loop ((n 10))
    (srfi-41-test-assert (even? (stream-ref (stream-filter odd? (stream-from 0)) n)) #f)
    (if (positive? n) (loop (- n 1))))

  ; stream-fold
  (srfi-41-test-assert (stream-fold "four" 0 strm123) "stream-fold: non-procedural argument")
  (srfi-41-test-assert (stream-fold + 0 '()) "stream-fold: non-stream argument")
  (srfi-41-test-assert (stream-fold + 0 strm123) 6)

  ; stream-for-each
  (srfi-41-test-assert (stream-for-each "four" strm123) "stream-for-each: non-procedural argument")
;  (srfi-41-test-assert (stream-for-each display) "stream-for-each: no stream arguments")
  (srfi-41-test-assert (stream-for-each display "four") "stream-for-each: non-stream argument")
  (srfi-41-test-assert (let ((sum 0)) (stream-for-each (lambda (x) (set! sum (+ sum x))) strm123) sum) 6)

  ; stream-from
  (srfi-41-test-assert (stream-from "four") "stream-from: non-numeric starting number")
  (srfi-41-test-assert (stream-from 1 "four") "stream-from: non-numeric step size")
  (srfi-41-test-assert (stream-ref (stream-from 0) 100) 100)
  (srfi-41-test-assert (stream-ref (stream-from 1 2) 100) 201)
  (srfi-41-test-assert (stream-ref (stream-from 0 -1) 100) -100)

  ; stream-iterate
  (srfi-41-test-assert (stream-iterate "four" 0) "stream-iterate: non-procedural argument")
  (srfi-41-test-assert (stream->list 3 (stream-iterate (lsec + 1) 1)) '(1 2 3))

  ; stream-length
  (srfi-41-test-assert (stream-length "four") "stream-length: non-stream argument")
  (srfi-41-test-assert (stream-length (stream)) 0)
  (srfi-41-test-assert (stream-length strm123) 3)

  ; stream-let
  (srfi-41-test-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
  (srfi-41-test-assert (stream-map "four" strm123) "stream-map: non-procedural argument")
;  (srfi-41-test-assert (stream-map odd?) "stream-map: no stream arguments")
  (srfi-41-test-assert (stream-map odd? "four") "stream-map: non-stream argument")
  (srfi-41-test-assert (stream->list (stream-map - strm123)) '(-1 -2 -3))
  (srfi-41-test-assert (stream->list (stream-map + strm123 strm123)) '(2 4 6))
  (srfi-41-test-assert (stream->list (stream-map + strm123 (stream-from 1))) '(2 4 6))
  (srfi-41-test-assert (stream->list (stream-map + (stream-from 1) strm123)) '(2 4 6))
  (srfi-41-test-assert (stream->list (stream-map + strm123 strm123 strm123)) '(3 6 9))

  ; stream-match
  (srfi-41-test-assert (stream-match '(1 2 3) (_ 'ok)) "stream-match: non-stream argument")
  (srfi-41-test-assert (stream-match strm123 (() 42)) "stream-match: pattern failure")
  (srfi-41-test-assert (stream-match stream-null (() 'ok)) 'ok)
  (srfi-41-test-assert (stream-match strm123 (() 'no) (else 'ok)) 'ok)
  (srfi-41-test-assert (stream-match (stream 1) (() 'no) ((a) a)) 1)
  (srfi-41-test-assert (stream-match (stream 1) (() 'no) ((_) 'ok)) 'ok)
  (srfi-41-test-assert (stream-match strm123 ((a b c) (list a b c))) '(1 2 3))
  (srfi-41-test-assert (stream-match strm123 ((a . _) a)) 1)
  (srfi-41-test-assert (stream-match strm123 ((a b . _) (list a b))) '(1 2))
  (srfi-41-test-assert (stream-match strm123 ((a b . c) (list a b (stream-car c)))) '(1 2 3))
  (srfi-41-test-assert (stream-match strm123 (s (stream->list s))) '(1 2 3))
  (srfi-41-test-assert (stream-match strm123 ((a . _) (= a 1) 'ok)) 'ok)
  (srfi-41-test-assert (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)) 'no)
  (srfi-41-test-assert (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)) 'no)
  (srfi-41-test-assert (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no)) 'yes)

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

  ; stream-range
  (srfi-41-test-assert (stream-range "four" 0) "stream-range: non-numeric starting number")
  (srfi-41-test-assert (stream-range 0 "four") "stream-range: non-numeric ending number")
  (srfi-41-test-assert (stream-range 1 2 "three") "stream-range: non-numeric step size")
  (srfi-41-test-assert (stream->list (stream-range 0 5)) '(0 1 2 3 4))
  (srfi-41-test-assert (stream->list (stream-range 5 0)) '(5 4 3 2 1))
  (srfi-41-test-assert (stream->list (stream-range 0 5 2)) '(0 2 4))
  (srfi-41-test-assert (stream->list (stream-range 5 0 -2)) '(5 3 1))
  (srfi-41-test-assert (stream->list (stream-range 0 1 -1)) '())

  ; stream-ref
  (srfi-41-test-assert (stream-ref '() 4) "stream-ref: non-stream argument")
  (srfi-41-test-assert (stream-ref nats 3.5) "stream-ref: non-integer argument")
  (srfi-41-test-assert (stream-ref nats -3) "stream-ref: negative argument")
  (srfi-41-test-assert (stream-ref strm123 5) "stream-ref: beyond end of stream")
  (srfi-41-test-assert (stream-ref strm123 0) 1)
  (srfi-41-test-assert (stream-ref strm123 1) 2)
  (srfi-41-test-assert (stream-ref strm123 2) 3)

  ; stream-reverse
  (srfi-41-test-assert (stream-reverse '()) "stream-reverse: non-stream argument")
  (srfi-41-test-assert (stream->list (stream-reverse (stream))) '())
  (srfi-41-test-assert (stream->list (stream-reverse strm123)) '(3 2 1))

  ; stream-scan
  (srfi-41-test-assert (stream-scan "four" 0 strm123) "stream-scan: non-procedural argument")
  (srfi-41-test-assert (stream-scan + 0 '()) "stream-scan: non-stream argument")
  (srfi-41-test-assert (stream->list (stream-scan + 0 strm123)) '(0 1 3 6))

  ; stream-take
  (srfi-41-test-assert (stream-take 5 "four") "stream-take: non-stream argument")
  (srfi-41-test-assert (stream-take "four" strm123) "stream-take: non-integer argument")
  (srfi-41-test-assert (stream-take -4 strm123) "stream-take: negative argument")
  (srfi-41-test-assert (stream->list (stream-take 5 stream-null)) '())
  (srfi-41-test-assert (stream->list (stream-take 0 stream-null)) '())
  (srfi-41-test-assert (stream->list (stream-take 0 strm123)) '())
  (srfi-41-test-assert (stream->list (stream-take 2 strm123)) '(1 2))
  (srfi-41-test-assert (stream->list (stream-take 3 strm123)) '(1 2 3))
  (srfi-41-test-assert (stream->list (stream-take 5 strm123)) '(1 2 3))

  ; stream-take-while
  (srfi-41-test-assert (stream-take-while odd? "four") "stream-take-while: non-stream argument")
  (srfi-41-test-assert (stream-take-while "four" strm123) "stream-take-while: non-procedural argument")
  (srfi-41-test-assert (stream->list (stream-take-while odd? strm123)) '(1))
  (srfi-41-test-assert (stream->list (stream-take-while even? strm123)) '())
  (srfi-41-test-assert (stream->list (stream-take-while positive? strm123)) '(1 2 3))
  (srfi-41-test-assert (stream->list (stream-take-while negative? strm123)) '())

  ; stream-unfold
  (srfi-41-test-assert (stream-unfold "four" odd? + 0) "stream-unfold: non-procedural mapper")
  (srfi-41-test-assert (stream-unfold + "four" + 0) "stream-unfold: non-procedural pred?")
  (srfi-41-test-assert (stream-unfold + odd? "four" 0) "stream-unfold: non-procedural generator")
  (srfi-41-test-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
  (srfi-41-test-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
;  (srfi-41-test-assert (stream-zip) "stream-zip: no stream arguments")
  (srfi-41-test-assert (stream-zip "four") "stream-zip: non-stream argument")
  (srfi-41-test-assert (stream-zip strm123 "four") "stream-zip: non-stream argument")
  (srfi-41-test-assert (stream->list (stream-zip strm123 stream-null)) '())
  (srfi-41-test-assert (stream->list (stream-zip strm123)) '((1) (2) (3)))
  (srfi-41-test-assert (stream->list (stream-zip strm123 strm123)) '((1 1) (2 2) (3 3)))
  (srfi-41-test-assert (stream->list (stream-zip strm123 (stream-from 1))) '((1 1) (2 2) (3 3)))
  (srfi-41-test-assert (stream->list (stream-zip strm123 strm123 strm123)) '((1 1 1) (2 2 2) (3 3 3)))

 ; other tests
  (srfi-41-test-assert
    (stream-car
      (stream-reverse
        (stream-take-while
          (rsec < 1000)
          primes)))
    997)

  (srfi-41-test-assert
    (equal?
      (stream->list (qsort < (stream 3 1 5 2 4)))
      (stream->list (isort < (stream 2 5 1 4 3))))
    #t)

  (srfi-41-test-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
  (srfi-41-test-assert (stream-ref hamming 999) 51200000)

;;; revert to old error procedure!
(set! error %old-error)
