;;;; 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-cardinal-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 ()
    ((define-stream (NAME . FORMAL) BODY0 BODY1 ...)
     (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)) ) ) )

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

(define-syntax stream-let
  (syntax-rules ()
    ((stream-let TAG ((NAME VAL) ...) BODY0 BODY1 ...)
     ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...) ) ) )

(define-syntax stream-match
  (syntax-rules ()
    ((stream-match 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 ()

    ((stream-match-test STRM (PATTERN FENDER EXPR))
     (stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))) )

    ((stream-match-test STRM (PATTERN EXPR))
     (stream-match-pattern STRM PATTERN () (list EXPR)) ) ) )

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

    ((stream-match-pattern STRM () (BINDING ...) BODY)
     (and (stream-null? STRM)
          (let (BINDING ...) BODY)) )

    ((stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
     (and (stream-pair? STRM)
          (let ((strm (stream-cdr STRM)))
            (stream-match-pattern strm REST (BINDING ...) BODY))) )

    ((stream-match-pattern 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))) )

    ((stream-match-pattern STRM _ (BINDING ...) BODY)
     (let (BINDING ...) BODY) )

    ((stream-match-pattern STRM VAR (BINDING ...) BODY)
     (let ((VAR STRM) BINDING ...) BODY) ) ) )

(define-syntax stream-of
  (syntax-rules (is in)
    ;
    ((stream-of "aux" EXPR BASE)
     (stream-cons EXPR BASE) )
    ;
    ((stream-of "aux" EXPR BASE (VAR in STREAM) REST ...)
     (stream-let loop ((strm STREAM))
       (if (stream-null? strm) BASE
           (let ((VAR (stream-car strm)))
             (stream-of "aux" EXPR (loop (stream-cdr strm)) REST ...)))) )
    ;
    ((stream-of "aux" EXPR BASE (VAR is EXP) REST ...)
     (let ((VAR EXP)) (stream-of "aux" EXPR BASE REST ...)) )
    ;
    ((stream-of "aux" EXPR BASE PRED? REST ...)
     (if PRED? (stream-of "aux" EXPR BASE REST ...) BASE) )
    ;
    ((stream-of 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))) ) )

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

(define (stream->list . args)
  (let* ((count (and (%fx< 1 (%list-length args)) (%car args)))
         (streem (if count (%cadr args) (%car args))))
    (%check-stream 'stream->list streem 'stream)
    (when count (%check-cardinal-integer 'stream->list count 'count))
    (let loop ((n (or count -1)) (strm streem))
      (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))))
    (%check-input-port 'port->stream port 'port)
    (port->stream$ port)) )

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

(define (stream-ref streem index)
  (%check-stream 'stream-ref streem 'stream)
  (%check-cardinal-integer 'stream-ref index 'index)
  (let loop ((strm streem) (n 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 streem)

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

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

(define (stream-append . streems)

  (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? streems) stream-null
      (begin
        (%check-streams 'stream-append streems 'stream)
        (stream-append$ streems) ) ) )

(define (stream-concat streem)

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

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

(define (stream-drop count streem)

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

  (%check-stream 'stream-drop streem 'stream)
  (%check-cardinal-integer 'stream-drop count 'count)
  (stream-drop$ count streem) )

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

  (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?)
  (%check-stream 'stream-drop-while streem 'stream)
  (stream-drop-while$ streem) )

(define (stream-take count streem)

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

  (%check-stream 'stream-take streem 'stream)
  (%check-cardinal-integer 'stream-take count 'count)
  (stream-take$ count streem) )

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

 (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?)
  (%check-stream 'stream-take-while streem 'stream)
  (stream-take-while$ streem) )

(define (stream-filter predicate? streem)

  (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?)
  (%check-stream 'stream-filter streem 'stream)
  (stream-filter$ streem) )

(define (stream-scan function base streem)

  (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)
  (%check-stream 'stream-scan streem 'stream)
  (stream-scan$ base streem) )

(define (stream-fold function base . streems)

  (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)
  (%check-streams 'stream-fold streems 'stream)
  (stream-folder base streems) )

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

  (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)
  (%check-streams 'stream-for-each streems 'stream)
  (stream-for-eacher streems) )

(define (stream-map function . streems)

  ; 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)
  (%check-streams 'stream-map streems 'stream)
  (stream-map$ streems) )

(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))))
    (%check-number 'stream-from first 'first)
    (%check-number 'stream-from delta 'delta)
    (stream-from$ first 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-streams 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-streams (unfold-result-stream seed)) )

(define (stream-zip . streems)

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

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

) ;module streams-derived