;;;; streams-derived.scm
;;;; Kon Lovett, Apr '09

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

(module streams-derived

  (;export
    ;; SRFI 41 derived
    define-stream stream stream-let
    stream-match
    stream-of
    stream-constant
    list->stream stream->list
    port->stream
    stream-length
    stream-ref
    stream-append stream-concat
    stream-reverse
    stream-drop stream-drop-while
    stream-take stream-take-while
    stream-filter stream-scan
    stream-fold stream-for-each stream-map
    stream-unfold stream-unfolds
    stream-from stream-iterate stream-range
    stream-zip
    ;; WTF
    stream-match-test
    stream-match-pattern)

  (import
    scheme chicken
    #;srfi-9 #;srfi-23
    streams-primitive
    (only type-errors
      error-number error-procedure
      error-natural-integer
      error-input-port error-list))

  (require-library
    #;srfi-9 #;srfi-23
    streams-primitive type-errors)

  (include "chicken-primitive-object-inlines")
  (include "streams-inlines")
  (include "inline-type-checks")

  (declare (bound-to-procedure ##sys#signal-hook))

;;;

(define-syntax define-stream
  (syntax-rules ()
    ((_ (?name . ?formal) ?body0 ?body1 ...)
     (define ?name (stream-lambda ?formal ?body0 ?body1 ...)) ) ) )

(define-syntax stream
  (syntax-rules ()
    ((_)         stream-null)
    ((_ X Y ...) (stream-cons X (stream Y ...)) ) ) )

(define-syntax stream-let
  (syntax-rules ()
    ((_ ?tag ((?name ?val) ...) ?body0 ?body1 ...)
     ((letrec ((?tag (stream-lambda (?name ...) ?body0 ?body1 ...))) ?tag) ?val ...) ) ) )

(define-syntax stream-match
  (syntax-rules ()
    ((_ ?strm-expr ?clause ...)
      (let ((strm ?strm-expr))
        (cond
          ((not (stream? strm))
            (error-stream 'stream-match strm 'stream))
          ((stream-match-test strm ?clause) => car)
          ...
          (else
            (error 'stream-match "no matching pattern")))) ) ) )

(define-syntax stream-match-test
  (syntax-rules ()

    ((_ ?strm (?pattern ?fender ?expr))
     (stream-match-pattern ?strm ?pattern () (and ?fender (list ?expr))) )

    ((_ ?strm (?pattern ?expr))
     (stream-match-pattern ?strm ?pattern () (list ?expr)) ) ) )

;FIXME - this forces use of `_' identifier
(define-syntax stream-match-pattern
  (syntax-rules (_)

    ((_ ?strm () (?binding ...) ?body)
     (and (stream-null? ?strm)
          (let (?binding ...) ?body)) )

    ((_ ?strm (_ . ?rest) (?binding ...) ?body)
     (and (stream-pair? ?strm)
          (let ((strm (stream-cdr ?strm)))
            (stream-match-pattern strm ?rest (?binding ...) ?body))) )

    ((_ ?strm (?var . ?rest) (?binding ...) ?body)
     (and (stream-pair? ?strm)
          (let ((temp (stream-car ?strm))
                (strm (stream-cdr ?strm)))
            (stream-match-pattern strm ?rest ((?var temp) ?binding ...) ?body))) )

    ((_ ?strm _ (?binding ...) ?body)
     (let (?binding ...) ?body) )

    ((_ ?strm ?var (?binding ...) ?body)
     (let ((?var ?strm) ?binding ...) ?body) ) ) )

(define-syntax stream-of
  (syntax-rules (is in)

    ((_ "aux" ?expr ?base)
     (stream-cons ?expr ?base) )

    ((_ "aux" ?expr ?base (?var in ?strm) ?rest ...)
     (stream-let loop ((strm ?strm))
       (if (stream-null? strm) ?base
           (let ((?var (stream-car strm)))
             (stream-of "aux" ?expr (loop (stream-cdr strm)) ?rest ...)))) )

    ((_ "aux" ?expr ?base (?var is ?exp) ?rest ...)
     (let ((?var ?exp)) (stream-of "aux" ?expr ?base ?rest ...)) )

    ((_ "aux" ?expr ?base ?pred? ?rest ...)
     (if ?pred? (stream-of "aux" ?expr ?base ?rest ...) ?base) )

    ((_ ?expr ?rest ...)
     (stream-of "aux" ?expr stream-null ?rest ...) ) ) )

;;

(define stream-constant
  (stream-lambda objs
    (cond
      ((%null? objs)
        stream-null )
      ((%null? (%cdr objs))
        (stream-cons (%car objs) (stream-constant (%car objs))) )
      (else
        (stream-cons
          (%car objs)
          (apply stream-constant (append (%cdr objs) (%list/1 (%car objs))))) ) ) ) )

(define (list->stream objects)

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

  (list->stream$ (%check-list 'list->stream objects 'objects)) )

(define (stream->list . args)
  (let* ((count (and (%fx< 1 (%list-length args))
                     (%check-natural-integer 'stream->list (%car args) 'count)))
         (strm (if count (%cadr args) (%car args)))
         (count (or count -1)) )
    (let loop ((n count) (strm (%check-stream 'stream->list strm 'stream)))
      (if (or (%fxzero? n) (stream-null? strm)) '()
        (%cons (stream-car strm) (loop (%fxsub1 n) (stream-cdr strm))) ) ) ) )

(define (port->stream . port)

  (define-stream (port->stream$ p)
    (let ((c (read-char p)))
      (if (%eof-object? c) stream-null
        (stream-cons c (port->stream$ p)) ) )  )

  (let ((port (if (%null? port) (current-input-port) (%car port))))
    (port->stream$ (%check-input-port 'port->stream port 'port))) )

(define (stream-length strm)
  (let loop ((len 0) (strm (%check-stream 'stream-length strm 'stream)))
    (if (stream-null? strm) len
      (loop (%fxadd1 len) (stream-cdr strm)) ) ) )

(define (stream-ref strm index)
  (let loop ((strm (%check-stream 'stream-ref strm 'stream))
             (n (%check-natural-integer 'stream-ref index 'index)))
    (cond
      ((stream-null? strm)
        (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) )
      ((%fxzero? n)
        (stream-car strm) )
      (else
        (loop (stream-cdr strm) (%fxsub1 n)) ) ) ) )

(define (stream-reverse strm)

  (define-stream (stream-reverse$ strm rev)
    (if (stream-null? strm) rev
      (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )

  (stream-reverse$ (%check-stream 'stream-reverse strm 'stream) stream-null) )

(define (stream-append . strms)

  (define-stream (stream-append$ strms)
    (cond
      ((%null? (%cdr strms))
        (%car strms) )
      ((stream-null? (%car strms))
        (stream-append$ (%cdr strms)) )
      (else
        (stream-cons
          (stream-car (%car strms))
          (stream-append$ (%cons (stream-cdr (%car strms)) (%cdr strms)))) ) ) )

  (if (%null? strms) stream-null
    (stream-append$ (%check-streams 'stream-append strms 'stream)) ) )

(define (stream-concat strm)

  (define-stream (stream-concat$ strm)
    (cond
      ((stream-null? strm)
        stream-null )
      ((not (stream? (stream-car strm)))
        (error-stream 'stream-concat strm) )
      ((stream-null? (stream-car strm))
        (stream-concat$ (stream-cdr strm)) )
      (else
        (stream-cons
          (stream-car (stream-car strm))
          (stream-concat$
            (stream-cons
              (stream-cdr (stream-car strm))
              (stream-cdr strm)))) ) ) )

  (stream-concat$ (%check-stream 'stream-concat strm 'stream)) )

(define (stream-drop count strm)

  (define-stream (stream-drop$ n strm)
    (if (or (%fxzero? n) (stream-null? strm)) strm
      (stream-drop$ (%fxsub1 n) (stream-cdr strm)) ) )

  (stream-drop$
    (%check-natural-integer 'stream-drop count 'count)
    (%check-stream 'stream-drop strm 'stream)) )

(define (stream-drop-while predicate? strm)

  (define-stream (stream-drop-while$ strm)
    (if (not (and (stream-pair? strm) (predicate? (stream-car strm)))) strm
      (stream-drop-while$ (stream-cdr strm)) ) )

  (%check-procedure 'stream-drop-while predicate? 'predicate?)
  (stream-drop-while$ (%check-stream 'stream-drop-while strm 'stream)) )

(define (stream-take count strm)

  (define-stream (stream-take$ n strm)
    (if (or (stream-null? strm) (%fxzero? n)) stream-null
      (stream-cons
        (stream-car strm)
        (stream-take$ (%fxsub1 n) (stream-cdr strm))) ) )

  (stream-take$
    (%check-natural-integer 'stream-take count 'count)
    (%check-stream 'stream-take strm 'stream)) )

(define (stream-take-while predicate? strm)

 (define-stream (stream-take-while$ strm)
    (cond
      ((stream-null? strm)
        stream-null )
      ((predicate? (stream-car strm))
        (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))) )
      (else
        stream-null ) ) )

  (%check-procedure 'stream-take-while predicate? 'predicate?)
  (stream-take-while$ (%check-stream 'stream-take-while strm 'stream)) )

(define (stream-filter predicate? strm)

  (define-stream (stream-filter$ strm)
    (cond
      ((stream-null? strm)
        stream-null )
      ((predicate? (stream-car strm))
        (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))) )
      (else
        (stream-filter$ (stream-cdr strm)) ) ) )

  (%check-procedure 'stream-filter predicate? 'predicate?)
  (stream-filter$ (%check-stream 'stream-filter strm 'stream)) )

(define (stream-scan function base strm)

  (define-stream (stream-scan$ base strm)
    (if (stream-null? strm) (stream base)
      (stream-cons
        base
        (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) )

  (%check-procedure 'stream-scan function 'function)
  (stream-scan$ base (%check-stream 'stream-scan strm 'stream)) )

(define (stream-fold function base . strms)

  (define (stream-folder base strms)
    (if (%list-any/1 stream-null? strms) base
      (stream-folder
        (apply function base (%list-map/1 stream-car strms))
        (%list-map/1 stream-cdr strms)) ) )

  (%check-procedure 'stream-fold function 'function)
  (stream-folder base (%check-streams 'stream-fold strms 'stream)) )

(define (stream-for-each procedure . strms)

  (define (stream-for-eacher strms)
    (unless (%list-any/1 stream-null? strms)
      (apply procedure (%list-map/1 stream-car strms))
      (stream-for-eacher (%list-map/1 stream-cdr strms)) ) )

  (%check-procedure 'stream-for-each procedure 'procedure)
  (stream-for-eacher (%check-streams 'stream-for-each strms 'stream)) )

(define (stream-map function . strms)

  ; not tail-recursive to avoid `stream-reverse'
  (define-stream (stream-map$ strms)
    (if (%list-any/1 stream-null? strms) stream-null
      (stream-cons
        (apply function (%list-map/1 stream-car strms))
        (stream-map$ (%list-map/1 stream-cdr strms))) ) )

  (%check-procedure 'stream-map function 'function)
  (stream-map$ (%check-streams 'stream-map strms 'stream)) )

(define (stream-from first . step)

  (define-stream (stream-from$ first delta)
    (stream-cons first (stream-from$ (%fx+ first delta) delta)) )

  (let ((delta (if (%null? step) 1 (%car step))))
    (stream-from$
      (%check-number 'stream-from first 'first)
      (%check-number 'stream-from delta 'delta)) ) )

(define (stream-iterate function base)

  (define-stream (stream-iterate$ base)
    (stream-cons base (stream-iterate$ (function base))) )

  (%check-procedure 'stream-iterate function 'function)
  (stream-iterate$ base) )

(define (stream-range first past . step)

  (define-stream (stream-range$ first past delta lt?)
    (if (not (lt? first past)) stream-null
      (stream-cons first (stream-range$ (%fx+ first delta) past delta lt?)) ) )

  (%check-number 'stream-range first 'first)
  (%check-number 'stream-range past 'past)
  (let ((delta (cond ((%pair? step) (%car step)) ((< first past) 1) (else -1))))
    (%check-number 'stream-range delta 'delta)
    (let ((lt? (if (< 0 delta) < >)))
      (stream-range$ first past delta lt?) ) ) )

(define (stream-unfold mapper predicate? generator base)

  (define-stream (stream-unfold$ base)
    (if (not (predicate? base)) stream-null
      (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )

  (%check-procedure 'stream-unfold mapper 'mapper)
  (%check-procedure 'stream-unfold predicate? 'predicate?)
  (%check-procedure 'stream-unfold generator 'generator)
  (stream-unfold$ base) )

(define (stream-unfolds generator seed)

  (define (len-values)
    (call-with-values
      (lambda () (generator seed))
      (lambda vs (%fxsub1 (%length vs)))) )

  (define-stream (unfold-result-stream seed)
    (call-with-values
      (lambda () (generator seed))
      (lambda (next . results)
        (stream-cons results (unfold-result-stream next)))) )

  (define-stream (result-stream->output-stream result-stream i)
    (let ((result (%list-ref (stream-car result-stream) (%fxsub1 i))))
      (cond
        ((%pair? result)
          (stream-cons
            (%car result)
            (result-stream->output-stream (stream-cdr result-stream) i)) )
        ((not result)
          (result-stream->output-stream (stream-cdr result-stream) i) )
        ((%null? result)
          stream-null )
        (else
          (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) )

  (define (result-stream->output-strms result-stream)
    (let loop ((i (len-values)) (outputs '()))
      (if (%fxzero? i) (apply values outputs)
        (loop (%fxsub1 i) (%cons (result-stream->output-stream result-stream i) outputs)) ) ) )

  (%check-procedure 'stream-unfolds generator 'generator)
  (result-stream->output-strms (unfold-result-stream seed)) )

(define (stream-zip . strms)

  (define-stream (stream-zip$ strms)
    (if (%list-any/1 stream-null? strms) stream-null
      (stream-cons
        (%list-map/1 stream-car strms)
        (stream-zip$ (%list-map/1 stream-cdr strms))) ) )

  (stream-zip$ (%check-streams 'stream-zip strms 'stream)) )

) ;module streams-derived