
;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public Licence version 3,
;; see file doc/LGPL-3.


;; <stream> = (:union (:pair <promise> <stream>) (:pair <null> <null>))


(define-module (th-scheme-utilities streams)
  #:declarative? #t)


(export stream-value
        stream-next
        stream-empty?
        stream-nonempty?
        stream-valid?
        stream-assert-valid
        stream-to-next!
        make-stream
        empty-stream
        stream-map
        stream-for-each
        stream->list
        list->stream
        stream-forward
        stream-ref
        get-expr-stream)


(use-modules (rnrs exceptions)
             (rnrs base)
             (th-scheme-utilities stdutils))


(define (stream-value stream) (force (car stream)))

(define (stream-next stream)
  (begin
   (force (car stream))
   (force (cdr stream))))

(define (stream-empty? stream)
  (and (null? (car stream)) (null? (cdr stream))))

(define (stream-nonempty? stream)
  (or (not-null? (car stream)) (not-null? (cdr stream))))

(define (stream-valid? stream)
  (and
   (pair? stream)
   (eq? (null? (car stream)) (null? (cdr stream)))))

(define (stream-assert-valid stream)
  (if (stream-valid? stream)
    #t
    (raise 'stream-invalid)))

(define (stream-to-next! stream)
  (if (stream-nonempty? stream)
    (let ((next (stream-next stream)))
      (set-car! stream (car next))
      (set-cdr! stream (cdr next))
      #t)
    #f))

(define (make-stream current next)
  (if (not (eq? (null? current) (null? next))) (raise 'stream-invalid-components))
  (cons current next))

(define (empty-stream) (cons '() '()))

(define (stream-map procedure . stream-list)
  (if (and-map? stream-nonempty? stream-list)
    (make-stream
     (delay (apply procedure (map stream-value stream-list)))
     (let ((next
            (lambda ()
              (apply stream-map
                (cons procedure
                      (map-in-order stream-next stream-list))))))
       (delay (next))))
    (empty-stream)))

(define (stream-for-each procedure . stream-list)
  (if (and-map? stream-nonempty? stream-list)
    (begin
     (apply procedure (map stream-value stream-list))
     (apply stream-for-each
       (cons procedure
             (map-in-order stream-next stream-list))))
    #f))

(define (stream->list stream)
  (if (stream-nonempty? stream)
    (cons (stream-value stream)
          (stream->list (stream-next stream)))
    '()))

(define (list->stream lst)
  (cond
    ((pair? lst)
     (make-stream
      (delay (car lst))
      (delay (list->stream (cdr lst)))))
    ((null? lst) (empty-stream))
    (else (throw 'argument-type-error))))

(define (stream-forward stream i)
  (cond
    ((< i 0) (throw 'invalid-index))
    ((= i 0) stream)
    ((stream-nonempty? stream)
     (stream-forward (stream-next stream) (- i 1)))
    (else (throw 'invalid-index))))

(define (stream-ref stream i)
  (stream-value (stream-forward stream i)))

(define (get-expr-stream port)
  (if (char-ready? port)
    (let ((next-expr (read port)))
      (if (eof-object? next-expr)
        (empty-stream)
        (make-stream
         (delay next-expr)
         (delay (get-expr-stream port)))))
    (empty-stream)))
