#| -*-Scheme-*-

$Id: srfi40.scm 4078 2007-09-18 18:56:30Z cph $

Copyright (C) 2003 by Philip L. Bewig of Saint Louis, Missouri, United
  States of America.  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.


Copyright (C) 2007 Massachusetts Institute of Technology

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#
;;;; SRFI-40 stream implementation

(declare (usual-integrations))

(define-record-type <stream> (%make-stream content) stream?
  (content %stream-content %set-stream-content!))

(define-guarantee stream "SRFI-40 stream")

(define-record-type <%promise> (%make-promise thunk) %promise?
  (thunk %promise-thunk))

(define (%force-stream stream)
  (let ((content (%stream-content stream)))
    (if (%promise? content)
	(let ((value ((%promise-thunk content))))
	  (without-interrupts
	   (lambda ()
	     (if (eq? (%stream-content stream) content)
		 (%set-stream-content! stream
				       (if (or (and (pair? value)
						    (stream? (cdr value)))
					       (null? value))
					   value
					   (begin
					     (guarantee-stream value)
					     (%stream-content value)))))))
	  (%force-stream stream))
	content)))

(define-syntax stream-delay
  (syntax-rules ()
    ((_ expr)
     (stream-delay-internal (lambda () expr)))))

(define (stream-delay-internal thunk)
  (%make-stream (%make-promise thunk)))

(define stream-null
  (%make-stream '()))

(define-syntax stream-cons
  (syntax-rules ()
    ((_ object stream)
     (stream-delay (cons object stream)))))

(define (stream-null? object)
  (and (stream? object)
       (null? (%force-stream object))))

(define (stream-pair? object)
  (and (stream? object)
       (pair? (%force-stream object))))

(define (stream-car stream)
  (let ((p (%force-stream stream)))
    (if (not (pair? p))
	(error:bad-range-argument stream 'stream-car))
    (car p)))

(define (stream-cdr stream)
  (let ((p (%force-stream stream)))
    (if (not (pair? p))
	(error:bad-range-argument stream 'stream-cdr))
    (cdr p)))

(define (stream . objs)
  (%list->stream objs))

(define (list->stream objs)
  (guarantee-list objs 'list->stream)
  (%list->stream objs))

(define (%list->stream objs)
  (stream-delay
   (if (pair? objs)
       (stream-cons (car objs) (%list->stream (cdr objs)))
       stream-null)))

(define (stream->list stream)
  (guarantee-stream stream 'stream->list)
  (let loop ((stream stream))
    (if (stream-pair? stream)
	(cons (stream-car stream) (loop (stream-cdr stream)))
	'())))

(define (stream-append stream . streams)
  (guarantee-stream stream 'stream-append)
  (for-each (lambda (stream)
	      (guarantee-stream stream 'stream-append))
	    streams)
  (let per-stream ((stream stream) (streams streams))
    (stream-delay
     (if (pair? streams)
	 (let per-elt ((stream stream))
	   (stream-delay
	    (if (stream-pair? stream)
		(stream-cons (stream-car stream)
			     (per-elt (stream-cdr stream)))
		(per-stream (car streams) (cdr streams)))))
	 stream))))

(define (stream-unfoldn gen seed n)
  (guarantee-exact-nonnegative-integer n 'stream-unfoldn)
  (let ((stream
	 (let loop ((seed seed))
	   (stream-delay
	    (receive (seed* . results) (gen seed)
	      (stream-cons results (loop seed*)))))))
    (apply values
	   (map (lambda (i)
		  (let loop ((stream stream))
		    (stream-delay
		     (let ((result (list-ref (stream-car stream) i)))
		       (cond ((and (pair? result)
				   (null? (cdr result)))
			      (stream-cons (car result)
					   (loop (stream-cdr stream))))
			     ((not result) (loop (stream-cdr stream)))
			     ((null? result) stream-null)
			     (else (error "Illegal result:" result)))))))
		(iota n)))))

(define (stream-map func stream . streams)
  (guarantee-procedure func 'stream-map)
  (let ((streams (cons stream streams)))
    (for-each (lambda (stream)
		(guarantee-stream stream 'stream-map))
	      streams)
    (let loop ((streams streams))
      (stream-delay
       (if (every stream-pair? streams)
	   (stream-cons (apply func (map stream-car streams))
			(loop (map stream-cdr streams)))
	   stream-null)))))

(define (stream-append-map func stream . streams)
  (guarantee-procedure func 'stream-append-map)
  (let ((streams (cons stream streams)))
    (for-each (lambda (stream)
		(guarantee-stream stream 'stream-append-map))
	      streams)
    (let loop ((streams streams))
      (stream-delay
       (if (every stream-pair? streams)
	   (stream-append (apply func (map stream-car streams))
			  (loop (map stream-cdr streams)))
	   stream-null)))))

(define (stream-for-each proc stream . streams)
  (guarantee-procedure proc 'stream-for-each)
  (let ((streams (cons stream streams)))
    (for-each (lambda (stream)
		(guarantee-stream stream 'stream-for-each))
	      streams)
    (let loop ((streams streams))
      (if (every stream-pair? streams)
	  (begin
	    (apply proc (map stream-car streams))
	    (loop (map stream-cdr streams)))))))

(define (stream-filter pred? stream)
  (guarantee-procedure pred? 'stream-filter)
  (guarantee-stream stream 'stream-filter)
  (let loop ((stream stream))
    (stream-delay
     (if (stream-pair? stream)
	 (if (pred? (stream-car stream))
	     (stream-cons (stream-car stream)
			  (loop (stream-cdr stream)))
	     (loop (stream-cdr stream)))
	 stream-null))))

(define (stream-every pred? stream . streams)
  (let loop ((streams (cons stream streams)))
    (if (every stream-pair? streams)
	(if (apply pred? (map stream-car streams))
	    (loop (map stream-cdr streams))
	    #f)
	#t)))

(define (stream-any pred? stream . streams)
  (let loop ((streams (cons stream streams)))
    (if (every stream-pair? streams)
	(if (apply pred? (map stream-car streams))
	    #t
	    (loop (map stream-cdr streams)))
	#f)))