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


(library (th-scheme-utilities streams)

  
  (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)


  (import (guile)
	  (rnrs exceptions)
	  (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))))
