;;;;
;;;; srfi-41.stk        -- Implementation of SRFI-41 (derived part)
;;;;
;;;; Copyright © 2020 Jeronimo Pellegrini - <j_p@aleph0.info>
;;;;
;;;;
;;;; 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 3 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; This file, except for the stream-match macro, is a derivative work
;;;; from the  implementation of
;;;; this SRFI by Philip L. Bewig, it is copyrighted as:

;;;;;;  Copyright (c) 2007 Philip L. Bewig.
;;;;;;  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.

;;;; The stream-match macro is part of Chibi Scheme, written by Alex
;;;; Shinn, and is copyrighted as:

;;;;; Copyright (c) 2009-2018 Alex Shinn
;;;;; All rights reserved.
;;;;;
;;;;; Redistribution and use in source and binary forms, with or without
;;;;; modification, are permitted provided that the following conditions
;;;;; are met:
;;;;; 1. Redistributions of source code must retain the above copyright
;;;;;    notice, this list of conditions and the following disclaimer.
;;;;; 2. Redistributions in binary form must reproduce the above copyright
;;;;;    notice, this list of conditions and the following disclaimer in the
;;;;;    documentation and/or other materials provided with the distribution.
;;;;; 3. The name of the author may not be used to endorse or promote products
;;;;;    derived from this software without specific prior written permission.
;;;;;
;;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;;;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;;;
;;;;           Author: Jeronimo Pellegrini [j_p@aleph0.info]
;;;;    Creation date: 09-Jul-2020 12:22 (jpellegrini)
;;;;


(define-module streams/derived
  (import (streams primitive)
          (scheme list))
  (export list->stream port->stream stream->list
          stream-append stream-concat stream-constant stream-drop
          stream-drop-while stream-filter stream-fold stream-for-each stream-from
          stream-iterate stream-length stream-map
          stream-range stream-ref stream-reverse stream-scan stream-take
          stream-take-while stream-unfold stream-unfolds stream-zip)
  (export define-stream stream stream-let stream-match stream-match-next
          stream-match-one stream-match-body stream-of stream-of-aux stream-of-aux2)



  (define exists any)

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

  (define (list->stream YYobjs)
    (define list->stream
      (stream-lambda (YYobjs)
        (if (null? YYobjs)
            stream-null
            (stream-cons (car YYobjs) (list->stream (cdr YYobjs))))))
    (if (not (list? YYobjs))
        (error 'list->stream "non-list argument")
        (list->stream YYobjs)))

  (define (port->stream . port)
    (define port->stream
      (stream-lambda (p)
        (let ((c (read-char p)))
          (if (eof-object? c)
              stream-null
              (stream-cons c (port->stream p))))))
    (let ((p (if (null? port) (current-input-port) (car port))))
      (if (not (input-port? p))
          (error 'port->stream "non-input-port argument")
          (port->stream p))))

  (define-syntax stream
    (syntax-rules ()
      ((stream) stream-null)
      ((stream x y ...) (stream-cons x (stream y ...)))))

  (define (stream->list . args)
    (let ((n (if (= 1 (length args)) #f (car args)))
          (strm (if (= 1 (length args)) (car args) (cadr args))))
      (cond ((not (stream? strm)) (error 'stream->list "non-stream argument"))
            ((and n (not (integer? n))) (error 'stream->list "non-integer count"))
            ((and n (negative? n)) (error 'stream->list "negative count"))
            (else (let loop ((n (if n n -1)) (strm strm))
                    (if (or (zero? n) (stream-null? strm))
                        '()
                        (cons (stream-car strm) (loop (- n 1) (stream-cdr strm)))))))))

  (define (stream-append . strms)
    (define stream-append
      (stream-lambda (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))))))))
    (cond ((null? strms) stream-null)
          ((exists (lambda (x) (not (stream? x))) strms)
            (error 'stream-append "non-stream argument"))
          (else (stream-append strms))))

  (define (stream-concat strms)
    (define stream-concat
      (stream-lambda (strms)
        (cond ((stream-null? strms) stream-null)
              ((not (stream? (stream-car strms)))
                (error 'stream-concat "non-stream object in input stream"))
              ((stream-null? (stream-car strms))
                (stream-concat (stream-cdr strms)))
              (else (stream-cons
                      (stream-car (stream-car strms))
                      (stream-concat
                        (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms))))))))
    (if (not (stream? strms))
        (error 'stream-concat "non-stream argument")
        (stream-concat strms)))

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

  (define (stream-drop n strm)
    (define stream-drop
      (stream-lambda (n strm)
        (if (or (zero? n) (stream-null? strm))
            strm
            (stream-drop (- n 1) (stream-cdr strm)))))
    (cond ((not (integer? n)) (error 'stream-drop "non-integer argument"))
          ((negative? n) (error 'stream-drop "negative argument"))
          ((not (stream? strm)) (error 'stream-drop "non-stream argument"))
          (else (stream-drop n strm))))

  (define (stream-drop-while pred? strm)
    (define stream-drop-while
      (stream-lambda (strm)
        (if (and (stream-pair? strm) (pred? (stream-car strm)))
            (stream-drop-while (stream-cdr strm))
            strm)))
    (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument"))
          ((not (stream? strm)) (error 'stream-drop-while "non-stream argument"))
          (else (stream-drop-while strm))))

  (define (stream-filter pred? strm)
    (define stream-filter
      (stream-lambda (strm)
        (cond ((stream-null? strm) stream-null)
              ((pred? (stream-car strm))
                (stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
              (else (stream-filter (stream-cdr strm))))))
    (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument"))
          ((not (stream? strm)) (error 'stream-filter "non-stream argument"))
          (else (stream-filter strm))))

  (define (stream-fold proc base strm)
    (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument"))
          ((not (stream? strm)) (error 'stream-fold "non-stream argument"))
          (else (let loop ((base base) (strm strm))
                  (if (stream-null? strm)
                      base
                      (loop (proc base (stream-car strm)) (stream-cdr strm)))))))

  (define (stream-for-each proc . strms)
    (define (stream-for-each strms)
      (if (not (exists stream-null? strms))
          (begin (apply proc (map stream-car strms))
                 (stream-for-each (map stream-cdr strms)))))
    (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument"))
          ((null? strms) (error 'stream-for-each "no stream arguments"))
          ((exists (lambda (x) (not (stream? x))) strms)
            (error 'stream-for-each "non-stream argument"))
          (else (stream-for-each strms))))

  (define (stream-from first . step)
    (define stream-from
      (stream-lambda (first delta)
        (stream-cons first (stream-from (+ first delta) delta))))
    (let ((delta (if (null? step) 1 (car step))))
      (cond ((not (number? first)) (error 'stream-from "non-numeric starting number"))
            ((not (number? delta)) (error 'stream-from "non-numeric step size"))
            (else (stream-from first delta)))))

  (define (stream-iterate proc base)
    (define stream-iterate
      (stream-lambda (base)
        (stream-cons base (stream-iterate (proc base)))))
    (if (not (procedure? proc))
        (error 'stream-iterate "non-procedural argument")
        (stream-iterate base)))

  (define (stream-length strm)
    (if (not (stream? strm))
        (error 'stream-length "non-stream argument")
        (let loop ((len 0) (strm strm))
          (if (stream-null? strm)
              len
              (loop (+ len 1) (stream-cdr strm))))))

  (define-syntax stream-let
    (syntax-rules ()
      ((stream-let tag ((name val) ...) body1 body2 ...)
       ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))))

  (define (stream-map proc . strms)
    (define stream-map
      (stream-lambda (strms)
        (if (exists stream-null? strms)
            stream-null
            (stream-cons (apply proc (map stream-car strms))
                         (stream-map (map stream-cdr strms))))))
    (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument"))
          ((null? strms) (error 'stream-map "no stream arguments"))
          ((exists (lambda (x) (not (stream? x))) strms)
            (error 'stream-map "non-stream argument"))
          (else (stream-map strms))))

;;; The following uses syntax-case. For this macro only, we have
;;; switched to Chibi's implementation
  ;; (define-syntax stream-match
  ;;   (syntax-rules ()
  ;;     ((stream-match strm-expr clause ...)
  ;;       (let ((strm strm-expr))
  ;;         (cond
  ;;           ((not (stream? strm)) (error 'stream-match "non-stream argument"))
  ;;           ((stream-match-test strm clause) => car) ...
  ;;           (else (error 'stream-match "pattern failure")))))))

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

  ;; (define-syntax stream-match-pattern
  ;;   (lambda (x)
  ;;     (define (wildcard? x)
  ;;       (and (identifier? x)
  ;;            (free-identifier=? x (syntax _))))
  ;;     (syntax-case x ()
  ;;       ((stream-match-pattern strm () (binding ...) body)
  ;;         (syntax (and (stream-null? strm) (let (binding ...) body))))
  ;;       ((stream-match-pattern strm (w? . rest) (binding ...) body)
  ;;         (wildcard? #'w?)
  ;;         (syntax (and (stream-pair? strm)
  ;;                      (let ((strm (stream-cdr strm)))
  ;;                        (stream-match-pattern strm rest (binding ...) body)))))
  ;;       ((stream-match-pattern strm (var . rest) (binding ...) body)
  ;;         (syntax (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 w? (binding ...) body)
  ;;         (wildcard? #'w?)
  ;;         (syntax (let (binding ...) body)))
  ;;       ((stream-match-pattern strm var (binding ...) body)
  ;;         (syntax (let ((var strm) binding ...) body))))))

;;; BEGIN portion taken from Chibi
(define-syntax stream-match
  (syntax-rules ()
    ((stream-match expr clause ...)
     (let ((strm expr))
       (if (not (stream? strm))
           (error 'stream-match "non-stream argument")
           (stream-match-next strm clause ...))))))

(define-syntax stream-match-next
  (syntax-rules ()
    ((stream-match-next strm)
     (error 'stream-match "pattern failure"))
    ((stream-match-next strm clause . clauses)
     (let ((fail (lambda () (stream-match-next strm . clauses))))
       (stream-match-one strm clause (fail))))))

(define-syntax stream-match-one
  (syntax-rules (_)
    ((stream-match-one strm (() . body) fail)
     (if (stream-null? strm)
         (stream-match-body fail . body)
         fail))
    ((stream-match-one strm (_ . body) fail)
     (stream-match-body fail . body))
    ((stream-match-one strm ((a . b) . body) fail)
     (if (stream-pair? strm)
         (stream-match-one
          (stream-car strm)
          (a
           (stream-match-one (stream-cdr strm) (b . body) fail))
          fail)
         fail))
    ((stream-match-one strm (a . body) fail)
     (let ((a strm))
       (stream-match-body fail . body)))))

(define-syntax stream-match-body
  (syntax-rules ()
    ((stream-match-body fail fender expr)
     (if fender expr fail))
    ((stream-match-body fail expr)
     expr)))
;;; END of portion from Chibi


  (define-syntax stream-of
    (syntax-rules ()
      ((_ expr rest ...)
        (stream-of-aux expr stream-null rest ...))))


  (define-macro (stream-of-aux2 expr base v . rest)
    (let ((var  (car v))
          (loop (gensym "loop"))
          (strm (gensym "strm"))
          (stream (caddr v)))
      `(stream-let ,loop ((,strm ,stream))
                   (if (stream-null? ,strm)
                       ,base
                       (let ((,var (stream-car ,strm)))
                         (stream-of-aux ,expr (,loop (stream-cdr ,strm)) ,@rest ))))))


  (define-syntax stream-of-aux
    (syntax-rules (in is)
      ((stream-of-aux expr base)
        (stream-cons expr base))

      ((stream-of-aux expr base (var in stream) rest ...)
       (stream-of-aux2 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))))

  (define (stream-range first past . step)
    (define stream-range
      (stream-lambda (first past delta lt?)
        (if (lt? first past)
            (stream-cons first (stream-range (+ first delta) past delta lt?))
            stream-null)))
    (cond ((not (number? first)) (error 'stream-range "non-numeric starting number"))
          ((not (number? past)) (error 'stream-range "non-numeric ending number"))
          (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
                  (if (not (number? delta))
                      (error 'stream-range "non-numeric step size")
                      (let ((lt? (if (< 0 delta) < >)))
                        (stream-range first past delta lt?)))))))

  (define (stream-ref strm n)
    (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument"))
          ((not (integer? n)) (error 'stream-ref "non-integer argument"))
          ((negative? n) (error 'stream-ref "negative argument"))
          (else (let loop ((strm strm) (n n))
                  (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream"))
                        ((zero? n) (stream-car strm))
                        (else (loop (stream-cdr strm) (- n 1))))))))

  (define (stream-reverse strm)
    (define stream-reverse
      (stream-lambda (strm rev)
        (if (stream-null? strm)
            rev
            (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev)))))
    (if (not (stream? strm))
        (error 'stream-reverse "non-stream argument")
        (stream-reverse strm stream-null)))

  (define (stream-scan proc base strm)
    (define stream-scan
      (stream-lambda (base strm)
        (if (stream-null? strm)
            (stream base)
            (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm))))))
    (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument"))
          ((not (stream? strm)) (error 'stream-scan "non-stream argument"))
          (else (stream-scan base strm))))

  (define (stream-take n strm)
    (define stream-take
      (stream-lambda (n strm)
        (if (or (stream-null? strm) (zero? n))
            stream-null
            (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm))))))
    (cond ((not (stream? strm)) (error 'stream-take "non-stream argument"))
          ((not (integer? n)) (error 'stream-take "non-integer argument"))
          ((negative? n) (error 'stream-take "negative argument"))
          (else (stream-take n strm))))

  (define (stream-take-while pred? strm)
    (define stream-take-while
      (stream-lambda (strm)
        (cond ((stream-null? strm) stream-null)
              ((pred? (stream-car strm))
                (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm))))
              (else stream-null))))
    (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument"))
          ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument"))
          (else (stream-take-while strm))))

  (define (stream-unfold mapper pred? generator base)
    (define stream-unfold
      (stream-lambda (base)
        (if (pred? base)
            (stream-cons (mapper base) (stream-unfold (generator base)))
            stream-null)))
    (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper"))
          ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?"))
          ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator"))
          (else (stream-unfold base))))

  (define (stream-unfolds gen seed)
    (define (len-values gen seed)
      (call-with-values
        (lambda () (gen seed))
        (lambda vs (- (length vs) 1))))
    (define unfold-result-stream
      (stream-lambda (gen seed)
        (call-with-values
          (lambda () (gen seed))
          (lambda (next . results)
            (stream-cons results (unfold-result-stream gen next))))))
    (define result-stream->output-stream
      (stream-lambda (result-stream i)
        (let ((result (list-ref (stream-car result-stream) (- i 1))))
          (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 (error 'stream-unfolds "can't happen"))))))
    (define (result-stream->output-streams result-stream)
      (let loop ((i (len-values gen seed)) (outputs '()))
        (if (zero? i)
            (apply values outputs)
            (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
    (if (not (procedure? gen))
        (error 'stream-unfolds "non-procedural argument")
        (result-stream->output-streams (unfold-result-stream gen seed))))

  (define (stream-zip . strms)
    (define stream-zip
      (stream-lambda (strms)
        (if (exists stream-null? strms)
            stream-null
            (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms))))))
    (cond ((null? strms) (error 'stream-zip "no stream arguments"))
          ((exists (lambda (x) (not (stream? x))) strms)
            (error 'stream-zip "non-stream argument"))
          (else (stream-zip strms))))

) ;; END OF DEFINE-MODULE

(provide "streams/derived")
