; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2012, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; 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.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT
; HOLDERS OR CONTRIBUTORS 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.
; 
; Last update: July 30, 2012
;
(require 'contracts)


(module %lazy-lists
  (Lazy make-lazy
   List->list list->List input->List
   First Rest Car Cdr Length Append Reverse
   List? Null? Realized? Reverse* Index
   Take Drop Ref Take-upto Drop-upto
   Memp Member Memq Memv
   Equ? Equal? Eq? Eqv?
   Assp Assoc Assq Assv
   Map Filter Sieve For-each
   Iterate Repeat Repeatedly
   Cardinals Primes Cycle Interval
   Nil Cons Merge Sort Split-at Split-with
   vector->List List->vector
   Fold-right Fold-left Fold-right* Fold-left*
   Zip Every? Some? List)

(import scheme
        (only chicken
              define-record-type
              define-record-printer
              cut
              add1
              sub1
              receive
              unless))

;; all defined operators hidden
(define lazy-list
  (define-record-type lazy-list
    (make-lazy-list length body value)
    lazy-list?
    (length lazy-list-length lazy-list-length-set!)
    (body lazy-list-body lazy-list-body-set!)
    (value lazy-list-value lazy-list-value-set!)))


(define-syntax Lazy
  (syntax-rules ()
    ((_ len xpr . xprs)
     (make-lazy len (lambda () xpr . xprs)))))

(define (Cons var seq)
  (let ((len (lazy-list-length seq)))
    (Lazy (if len (+ 1 len) #f)
      (cons var seq))))

(define (make-lazy len body)
  (make-lazy-list len body #f))

(define Length lazy-list-length)

(define List? lazy-list?)

(define Nil
  (make-lazy-list 0 (lambda () '()) #f))

(define (Cardinals)
  (let loop ((n 0)) (Lazy #f (cons n (loop (+ n 1))))))

(define (Primes)
  (Sieve (lambda (x y) (zero? (remainder x y)))
         (Drop 2 (Cardinals))))

(define-record-printer (lazy-list seq out)
  (display "#<List[" out)
  (display (lazy-list-length seq) out)
  (display "]" out)
  (cond ((not (Realized? seq))
         (display " ...>" out))
        ((Null? seq)
         (display "]>" out))
        (else
         (let loop ((seq seq))
           (if (Realized? seq)
               (if (Null? seq)
                   (display ">" out)
                   (begin
                     (display " " out)
                     (write (First seq) out)
                     (loop (Rest seq))))
               (display " ...>" out))))))

(define (Realized? seq)
  (not (lazy-list-body seq)))

(define (Null? seq)
  (null? (realize seq)))

;; hidden, does most of the dirty work
(define (realize seq)
  (or (lazy-list-value seq)
      (let ((value ((lazy-list-body seq))))
        (lazy-list-body-set! seq #f)
        (let loop ((value value))
          (if (or (null? value) (pair? value))
              (begin
                (lazy-list-value-set! seq value)
                value)
              (loop (or (lazy-list-value value)
                        ((lazy-list-body value)))))))))

(define (First seq)
  (car (realize seq)))

(define Car First)

;; to speed up cdring for lists with preknown length
(define (rest seq)
  (cdr (realize seq)))

(define (Rest seq)
  (let (
    (len (lazy-list-length seq))
    (Result (cdr (realize seq)))
    )
    (lazy-list-length-set! Result (if len (- len 1) #f))
    Result))

(define Cdr Rest)

(define (Ref n seq)
  (if (zero? n)
      (First seq)
      (Ref (- n 1) (Rest seq))))

(define (List->list seq)
  (let loop ((lst '()) (seq seq))
    (if (Null? seq)
      (reverse lst)
      (loop (cons (First seq) lst)
            (Rest seq)))))

(define (list->List lst)
  (let loop ((lst (reverse lst)) (seq Nil))
    (if (null? lst)
      seq
      (loop (cdr lst) (Cons (car lst) seq)))))

(define (List . args)
  (list->List args))

(define (Take n seq)
  (call-with-values
    (lambda () (Split-at n seq))
    (lambda (a b) a)))

(define (Drop n seq)
  (call-with-values
    (lambda () (Split-at n seq))
    (lambda (a b) b)))

(define (Take-upto ok? seq)
;  (let loop ((len (lazy-list-length seq)) (seq seq))
;    (cond
;      ((Null? seq) Nil)
;      ((ok? (First seq))
;       (Lazy len
;         (cons (First seq)
;               (loop (if len (- len 1) #f)
;                     (Rest seq)))))
;      (else Nil))))
  (receive (head index tail) (Split-with ok? seq)
    head))

(define (Index ok? seq)
  (receive (head index tail) (Split-with ok? seq)
    index))

(define (Drop-upto ok? seq)
;  (let loop ((len (lazy-list-length seq)) (seq seq))
;    (cond
;      ((Null? seq) Nil)
;      ((ok? (First seq))
;       (loop (if len (- len 1) #f)
;             (Rest seq)))
;      (else
;        (Lazy len seq)))))
  (receive (head index tail) (Split-with ok? seq)
    tail))

(define (Memp ok? seq)
  (Drop-upto ok? seq))

(define (Memq var seq)
  (Memp (cut eq? <> var) seq))

(define (Memv var seq)
  (Memp (cut eqv? <> var) seq))

(define (Member var seq)
  (Memp (cut equal? <> var) seq))

(define (Equ? =? seq1 seq2)
  (if (eqv? (lazy-list-length seq1) (lazy-list-length seq2))
    (if (lazy-list-length seq1)
      ;; both finite
      (let loop ((seq1 seq1) (seq2 seq2))
        (cond
          ((Null? seq1) #t)
          ((=? (First seq1) (First seq2))
           (loop (Rest seq1) (Rest seq2)))))
      ;; both infinite
      (eq? seq1 seq2))
    #f))

(define (Eq? seq1 seq2)
  (Equ? eq? seq1 seq2))

(define (Eqv? seq1 seq2)
  (Equ? eqv? seq1 seq2))

(define (Equal? seq1 seq2)
  (Equ? equal? seq1 seq2))

(define (Assp ok? al)
  (let (
    (seq (Drop-upto (lambda (pair) (ok? (car pair))) al))
    )
    (if (Null? seq) #f (First seq))))

(define (Assq key al)
  (Assp (cut eq? <> key) al))

(define (Assv key al)
  (Assp (cut eqv? <> key) al))

(define (Assoc key al)
  (Assp (cut equal? <> key) al))

(define (Map proc seq . seqs)
  ;; all equal length, as in R5RS Standard
  (let (
    (seqs (cons seq seqs))
    (len (lazy-list-length seq))
    )
    (let loop ((seqs seqs))
      (Lazy len
        (if (Null? (car seqs))
            '()
            (cons (apply proc (map First seqs))
                  (loop (map rest seqs))))))))

(define (Filter ok? seq)
  (let loop ((seq seq))
    (if (Null? seq)
      Nil
      (let ((first (First seq)))
        (if (lazy-list-length seq)
          ;; compute new length via Cons
          (if (ok? first)
            (Cons first (loop (Rest seq)))
            (loop (Rest seq)))
          (Lazy #f
            (if (ok? first)
              (cons first (loop (rest seq)))
              (loop (rest seq)))))))))

(define (For-each proc seq . seqs)
  ;; all equal finite length, as in R5RS Standard
  (let ((seqs (cons seq seqs)))
    (unless (Null? seq)
      (apply proc (map First seqs))
      (apply For-each proc (map Rest seqs)))))

(define (input->List port read)
  (let loop ()
    ;(Lazy #f
      (let ((datum (read port)))
        (if (eof-object? datum)
            Nil
            ;'()
            (Cons datum (loop))))));)

(define (Repeat x)
  (Lazy #f (cons x (Repeat x))))

(define (Repeatedly thunk)
  (Lazy #f (cons (thunk) (Repeatedly thunk))))

(define (Iterate f x)
  (Lazy #f
    (cons x (Iterate f (f x)))))

(define (Interval from upto)
  (Take (abs (- upto from))
        (Iterate (if (>= upto from) add1 sub1) from)))

(define (Append2 seq1 seq2)
  (let loop ((seq seq1))
    (Lazy (if (lazy-list-length seq2)
            (+ (lazy-list-length seq1)
               (lazy-list-length seq2)) #f)
      (if (Null? seq)
        seq2
        (cons (First seq) (loop (rest seq)))))))

(define (Append . seqs)
  (cond
    ((null? seqs) Nil)
    ((null? (cdr seqs)) (car seqs))
    (else
      (Append2 (car seqs) (apply Append (cdr seqs))))))

(define (Reverse seq)
  (let loop ((seq seq) (reverse Nil))
    (if (Null? seq)
      reverse
      (Lazy (lazy-list-length seq)
        (loop (rest seq)
              (Cons (First seq) reverse))))))

(define (Reverse* seq)
  (letrec (
    (result 
      (Cons Nil
        (Map Cons
             seq
             (Lazy (lazy-list-length seq) result))))
    )
    (Rest result)))

(define (Cycle seq)
  (if (Null? seq)
      Nil
      (let loop ((tail seq))
        (Lazy #f
          (if (Null? tail)
              (loop seq)
              (cons (First tail)
                    (loop (rest tail))))))))

(define (Merge <? seq1 seq2)
  (let ((len (+ (lazy-list-length seq1) (lazy-list-length seq2))))
    (let loop ((seq1 seq1) (seq2 seq2))
      (cond
        ((Null? seq1) seq2)
        ((Null? seq2) seq1)
        ((<? (First seq1) (First seq2))
         (Lazy len (cons (First seq1) (loop (rest seq1) seq2))))
        (else 
         (Lazy len
               (cons (First seq2) (loop seq1 (rest seq2)))))))))

(define (Sort <? seq)
  (let ((len (lazy-list-length seq)))
    (if (< len 2)
      seq
      (let ((halflen (quotient len 2)))
        (Merge <?
          (Sort <? (Take halflen seq))
          (Sort <? (Drop halflen seq)))))))

(define (vector->List vec)
  (let loop ((res Nil) (n (vector-length vec)))
    (if (zero? n)
      res
      (loop (Cons (vector-ref vec (- n 1)) res) (- n 1)))))

;; see comment to List->list
(define (List->vector seq)
  (let ((vec (make-vector (lazy-list-length seq) #f)))
    (let loop ((k 0) (seq seq))
      (cond
        ((Null? seq)
         vec)
        (else
          (vector-set! vec k (First seq))
          (loop (+ k 1) (rest seq)))))))

(define (Split-at n seq)
  (let loop ((n n) (head Nil) (tail seq))
    (if (or (Null? tail) (zero? n))
      (values (Reverse head) tail)
      (loop (- n 1)
            (Cons (First tail) head)
            (Rest tail)))))

(define (Split-with ok? seq)
  (let loop ((head Nil) (index 0) (tail seq))
    (if (or (Null? tail) (ok? (First tail)))
      (values (Reverse head) index tail)
      (loop (Cons (First tail) head)
            (+ index 1)
            (Rest tail)))))

(define (Sieve =? seq)
  (let loop ((seq seq))
    (if (Null? seq)
      Nil
      (let (
        (first (First seq))
        (tail
          (Filter
            (lambda (x)
              (not (=? x (First seq))))
            (Rest seq)))
        )
        (if (lazy-list-length seq)
          (Cons first (loop tail))
          (Lazy #f
            (cons first (loop tail))))))))

(define (Fold-left op base seq . seqs)
  ; all equal finite length
  (let loop ((base base) (seqs (cons seq seqs)))
    (if (Null? (car seqs))
      base
      (loop (apply op base (map First seqs))
            (map Rest seqs)))))

(define (Fold-right op base seq . seqs)
  ; all equal finite length
  (let loop ((seqs (cons seq seqs)))
    (if (Null? (car seqs))
      base
      (apply op 
             (append (map First seqs)
                     (list (loop (map Rest seqs))))))))

;;; The following two routines return Lists
(define (Fold-left* op base . seqs)
  ;; all of equal length
  (letrec (
    (fold
      (Cons base
        (apply Map op
                   (Lazy (if (null? seqs)
                           #f
                           (lazy-list-length (car seqs))) fold)
                   seqs)))
    )
    (Rest fold)))

(define (Fold-right* op base . seqs) ; changes order of List items
  ;; all of equal length
  (letrec (
    (fold
      (Cons base
        (apply Map op
               (append seqs
                       (list
                         (Lazy (if (null? seqs)
                                 #f
                                 (lazy-list-length (car seqs)))
                           fold))))))
    )
    (Rest fold)))

(define (Every? ok? seq)
  (let loop ((seq seq))
    (cond
      ((Null? seq) #t)
      ((ok? (First seq))
       (loop (Rest seq)))
      (else #f))))

(define (Some? ok? seq)
  (let loop ((seq seq))
    (cond
      ((Null? seq) #f)
      ((ok? (First seq)) #t)
      (else
        (loop (Rest seq))))))

(define (Zip seq1 seq2)
  (if (Null? seq1)
    seq2
    (if (and (lazy-list-length seq1) (lazy-list-length seq2))
      ;; both finite, compute new length with Cons
      (Cons (First seq1) (Zip seq2 (Rest seq1)))
      ;; new length infinite
      (Lazy #f 
        (cons (First seq1) (Zip seq2 (Rest seq1)))))))
   
;; hidden helpers
(define (all ok? lst)
  (let loop ((lst lst))
    (cond
      ((null? lst) #t)
      ((ok? (car lst))
       (loop (cdr lst)))
      (else #f))))

) ; module %lazy-lists

(module lazy-lists
  (Lazy make-lazy Car Cdr Nil Cons 
   List->list list->List input->List
   First Rest Length Append Reverse
   List? Null? Realized? Reverse*
   Take Drop Ref Take-upto Drop-upto
   Memp Member Memq Memv Index
   Equ? Equal? Eq? Eqv?
   Assp Assoc Assq Assv
   Map Filter Sieve For-each
   Iterate Repeat Repeatedly
   Cardinals Primes Cycle Interval
   Merge Sort Split-at Split-with
   vector->List List->vector
   Fold-right Fold-left Fold-right* Fold-left* Zip
   Every? Some? List lazy-lists)

(import scheme
        contracts
        (only data-structures list-of?)
        (prefix %lazy-lists %))

;; initialize documentation
(doclist '((Nil  "empty lazy list")))

(define-syntax-with-contract Lazy
  "wrapper to make-lazy constructor"
  (syntax-rules ()
    ((_ len xpr . xprs)
     (%make-lazy len (lambda () xpr . xprs)))))

(define-with-contract (Cons var seq)
  "lazy version of cons"
  (domain (%List? seq))
  (range (%List? result)
         (or (not (%Length seq))
             (= (%Length result) (+ (%Length seq) 1)))) 
  (%Cons var seq))

(define-with-contract (make-lazy len thunk)
  "lazy constructor"
  (domain (or (not len)
              (and (integer? len)
                   (not (negative? len))))
          (procedure? thunk)
          "thunk returns either '(), a List or (cons val List)")
  (range (%List? result) (= (%Length result) len))
  (%make-lazy len thunk))

(define-with-contract (Length seq)
  "lazy version of length"
  (domain (%List? seq))
  (range (or (not result)
             (and (integer? result)
                  (not (negative? result)))))
  (%Length seq))

(define-with-contract (List? xpr)
  "lazy version of list?"
  (range (boolean? result))
  (%List xpr))

(define Nil
  %Nil)

(define-with-contract (Interval from upto)
  "List of integers from (included) upto (excluded)"
  (domain (integer? from) (integer? upto))
  (range (%List result)
         (= (%Length result) (abs (- upto from))))
  (%Interval from upto))

(define-with-contract (Cardinals)
  "lazy list of non negative integers"
  (range (%List? result) (not (%Length result)))
  (%Cardinals))

(define-with-contract (Primes)
  "lazy list of non prime numbers"
  (range (%List? result) (not (%Length result)))
  (%Primes))

(define-with-contract (Realized? seq)
  "Is seq realized?"
  (domain (%List? seq))
  (range (boolean? result))
  (%Realized? seq))

(define-with-contract (Null? seq)
  "lazy version of null?"
  (domain (%List? seq))
  (range (boolean? result))
  (%Null? seq))

(define-with-contract (Car seq)
  "lazy version of car"
  (domain (%List? seq) (not (%Null? seq)))
  (%First seq))

(define-with-contract (First seq)
  "lazy version of car"
  (domain (%List? seq) (not (%Null? seq)))
  (%First seq))

(define-with-contract (Cdr seq)
  "lazy version of cdr"
  (domain (%List? seq) (not (%Null? seq)))
  (range (%List? result)
         (or (not (%Length seq))
             (= (%Length result) (- (%Length seq) 1))))
  (%Rest seq))

(define-with-contract (Rest seq)
  "lazy version of cdr"
  (domain (%List? seq) (not (%Null? seq)))
  (range (%List? result)
         (or (not (%Length seq))
             (= (%Length result) (- (%Length seq) 1))))
  (%Rest seq))

(define-with-contract (Ref n seq)
  "lazy version of list-ref with changed argument order"
  (domain (%List? seq) (integer? n)
          (or (not (%Length seq))
              (< -1 n (%Length seq))))
  (%Ref n seq))

(define-with-contract (List->list seq)
  "transform finite lazy into ordinary list"
  (domain (%List? seq) (%Length seq))
  (range (list? result))
  (%List->list seq))

(define-with-contract (list->List lst)
  "transform ordinary list into finite lazy list"
  (domain (list? lst))
  (range (%List? result)
         (eqv? (%Length result) (length lst)))
  (%list->List lst))

(define-with-contract (List . args)
  "lazy version of list"
  (range (%List? result)
         (eqv? (%Length result) (length args)))
  (apply %List args))

(define-with-contract (Take n seq)
  "List of first n items of seq"
  (domain (%List? seq)
          (integer? n) (not (negative? n)))
  (range (%List? result) (%Length result)
         (if (%Length seq)
             (= (%Length result) (min n (%Length seq)))
             (= (%Length result) n)))
  (%Take n seq))

(define-with-contract (Drop n seq)
  "lazy version of list-tail with changed argument order"
  (domain (%List? seq)
          (integer? n) (not (negative? n)))
  (range (%List? result)
         (if (%Length seq)
             (= (%Length result) (max 0 (- (%Length seq) n)))
             (not (%Length result))))
  (%Drop n seq))


(define-with-contract (Take-upto ok? seq)
  "List of head items fulfilling ok?"
  (domain (%List? seq) (%Length seq)
          (procedure? ok?) "(ok? x)")
  (range (%List? result)
         (<= (%Length result) (%Length seq)))
  (%Take-upto ok? seq))

(define-with-contract (Drop-upto ok? seq)
  "Tail of items not fulfilling ok?"
  (domain (%List? seq) (%Length seq)
          (procedure? ok?) "(ok? x)")
  (range (%List? result)
         (<= (%Length result) (%Length seq)))
  (%Drop-upto ok? seq))

(define-with-contract (Index ok? seq)
  "return index of first item fulfilling ok?"
  (domain (%List? seq) (%Length seq)
          (procedure? ok?) "(ok? x)")
  (range (integer? result)
         (not (negative? result)))
  (%Index ok? seq))

(define-with-contract (Memp ok? seq)
  "Tail of items not fulfilling ok?"
  (domain (%List? seq) (%Length seq)
          (procedure? ok?) "(ok? x)")
  (range (%List? result)
         (<= (%Length result) (%Length seq)))
  (%Memp ok? seq))

(define-with-contract (Memq var seq)
  "lazy version of memq"
  (domain (%List? seq) (%Length seq))
  (range (%List? result)
         (<= (%Length result) (%Length seq)))
  (%Memq var seq))

(define-with-contract (Memv var seq)
  "lazy version of memv"
  (domain (%List? seq) (%Length seq))
  (range (%List? result)
         (<= (%Length result) (%Length seq)))
  (%Memv var seq))

(define-with-contract (Member var seq)
  "lazy version of member"
  (domain (%List? seq) (%Length seq))
  (range (%List? result)
         (<= (%Length result) (%Length seq)))
  (%Member var seq))

(define-with-contract (Equ? =? seq1 seq2)
  "compare two Lists with predicate =?"
  (domain (%List? seq1) (%List? seq2)
          (procedure? =?) "(=? x y)")
  (range (boolean? result))
  (%Equ? =? seq1 seq2))

(define-with-contract (Eq? seq1 seq2)
  "lazy version of eq?"
  (domain (%List? seq1) (%List? seq2))
  (range (boolean? result))
  (%Equ? eq? seq1 seq2))
  ;(%Eq? seq1 seq2))


(define-with-contract (Eqv? seq1 seq2)
  "lazy version of eqv?"
  (domain (%List? seq1) (%List? seq2))
  (range (boolean? result))
  (%Equ? eqv? seq1 seq2))
  ;(%Eqv? seq1 seq2))

(define-with-contract (Equal? seq1 seq2)
  "lazy version of equal?"
  (domain (%List? seq1) (%List? seq2))
  (range (boolean? result))
  (%Equ? equal? seq1 seq2))
  ;(%Equal? seq1 seq2))

(define-with-contract (Assp ok? aseq)
  "return #f or first pair, whose Car fulfills ok?"
  (domain (%List? aseq) "List of pairs" (%Length aseq)
          (procedure? ok?) "(ok? x)")
  (range (or (not result) (pair? result)))
  (%Assp ok? aseq))

(define-with-contract (Assq key aseq)
  "lazy version of assq"
  (domain (%List? aseq) "List of pairs" (%Length aseq))
  (range (or (not result) (pair? result)))
  (%Assq key aseq))

(define-with-contract (Assv key aseq)
  "lazy version of assv"
  (domain (%List? aseq) "List of pairs" (%Length aseq))
  (range (or (not result) (pair? result)))
  (%Assv key aseq))

(define-with-contract (Assoc key aseq)
  "lazy version of assoq"
  (domain (%List? aseq) "List of pairs" (%Length aseq))
  (range (or (not result) (pair? result)))
  (%Assoc key aseq))

(define-with-contract (Map proc seq . seqs)
  "lazy version of map"
  (domain (%List? seq)
          ((list-of? %List?) seqs)
          (procedure? proc) "(proc arg . args)"
          (all (lambda (x) (eqv? (%Length x) (%Length seq))) seqs))
  (range (%List? result) (eqv? (%Length result) (%Length seq)))
  (apply %Map proc seq seqs))

(define-with-contract (Filter ok? seq)
  "lazy version of filter"
  (domain (%List? seq)
          (procedure? ok?) "(ok? x)")
  (range (%List? result)
         (or (not (%Length seq))
           (<= (%Length result) (%Length seq))))
  (%Filter ok? seq))

(define-with-contract (For-each proc seq . seqs)
  "lazy version of for-each"
  (domain (%List? seq)
          ((list-of? %List?) seqs)
          (procedure? proc) "(proc arg . args)"
          (all (lambda (x) (eqv? (%Length x) (%Length seq))) seqs))
  (apply %For-each proc seq seqs))

(define-with-contract (input->List port read-proc)
  "transform input port into List with read-proc"
  (domain (input-port? port) (procedure? read-proc))
  (range (%List? result) (%Length result))
  (%input->List port read-proc))

(define-with-contract (Repeat x)
  "create infinite List of x"
  (range (%List? result) (not (%Length result)))
  (%Repeat x))

(define-with-contract (Repeatedly thunk)
  "create infinite List of return values of thunk"
  (domain (procedure? thunk))
  (range (%List? result) (not (%Length result)))
  (%Repeatedly thunk))

(define-with-contract (Iterate proc x)
  "create infinite List by applying proc succesively to x"
  (domain (procedure? proc) "(proc x)")
  (range (%List? result) (not (%Length result)))
  (%Iterate proc x))

(define-with-contract (Append . seqs)
  "lazy version of append"
  (domain ((list-of? %List?) seqs)
          (let ((lst (memv #f (map %Length seqs))))
            (or (not lst) (<= (length lst) 1))))
  (range (%List? result)
         (or (not (%Length result))
             (= (%Length result) (apply + (map %Length seqs)))))
  (apply %Append seqs))

(define-with-contract (Reverse seq)
  "lazy version of reverse"
  (domain (%List? seq) (%Length seq))
  (range (%List? result) (%Length result)
         (= (%Length result) (%Length seq)))
  (%Reverse seq))

(define-with-contract (Reverse* seq)
  "List of successive reversed subLists"
  (domain (%List? seq))
  (range (%List? result)
         (eqv? (%Length result) (%Length seq)))
  (%Reverse* seq))


(define-with-contract (Cycle seq)
  "create infinite List by cycling finite List seq"
  (domain (%List? seq) (%Length seq))
  (range (%List? result) (not (%Length result)))
  (%Cycle seq))

(define-with-contract (Merge <? seq1 seq2)
  "merge two sorted lazy lists with respect to <?"
  (domain (procedure? <?) "(<? a b)"
          (%List? seq1) (%Length seq1) "<? sorted"
          (%List? seq2) (%Length seq2) "<? sorted")
  (range (%List? result) "<? sorted"
         (= (%Length result)
            (+ (%Length seq1) (%Length seq2))))
  (%Merge <? seq1 seq2))

(define-with-contract (Sort <? seq)
  "sort a finite lazy list with respect to <?"
  (domain (procedure? <?) "(<? a b)"
          (%List? seq) (%Length seq))
  (range (%List? result) "<? sorted"
         (eqv? (%Length result) (%Length seq)))
  (%Sort <? seq))

(define-with-contract (vector->List vec)
  "transform a vector into a lazy list"
  (domain (vector? vec))
  (range (%List? result)
         (eqv? (%Length result) (vector-length vec)))
  (%vector->List vec))

(define-with-contract (List->vector seq)
  "transform a finite lazy list into a vector"
  (domain (%List? seq) (%Length seq))
  (range (vector? result)
         (eqv? (vector-length result) (%Length seq)))
  (%List->vector seq))

(define-with-contract (Split-at n seq)
  "split a List at fixed position"
  (domain (%List? seq)
          (integer? n) (not (negative? n)))
  (range (with-results (head tail)
           (%List? head) (%Length head)
           (<= (%Length head) n)
           (%List? tail)
           (if (%Length seq)
             (<= (%Length tail) (%Length seq))
             (not (%Length tail)))))
  (%Split-at n seq))

(define-with-contract (Split-with ok? seq)
  "split a lazy list at first index fulfilling ok?"
  (domain (%List? seq) (%Length seq)
          (procedure? ok?) "(ok? x)")
  (range (with-results (head index tail)
           (%List? head) (%List? tail)
           (integer? index) (not (negative? index))
           (<= (%Length head) (%Length seq))
           (<= (%Length tail) (%Length seq))))
  (%Split-with ok? seq))

(define-with-contract (Sieve =? seq)
  "sievo of Erathostenes with respect to =?"
  (domain (%List? seq)
          (procedure? =?) "(=? a b)")
  (range (%List? result) "not two items =?"
         (if (%Length seq)
           (<= (%Length result) (%Length seq))
           (not (%Length result))))
  (%Sieve =? seq))

(define-with-contract (Fold-left op base seq . seqs)
  "lazy version of fold-left"
  (domain (procedure? op) "(op b s . ss)"
          (%List? seq) ((list-of? %List?) seqs)
          (%Length seq)
          (all (lambda (x) (= (%Length x) (%Length seq))) seqs))
  (apply %Fold-left op base seq seqs))

(define-with-contract (Fold-right op base seq . seqs)
  "lazy version of fold-right"
  (domain (procedure? op) "(op b s . ss)"
          (%List? seq) ((list-of? %List?) seqs)
          (%Length seq)
          (all (lambda (x) (= (%Length x) (%Length seq))) seqs))
  (apply %Fold-right op base seq seqs))

(define-with-contract (Fold-left* op base . seqs)
  "create a lazy list of left folds"
  (domain (procedure? op) "(op b . ss)"
          ((list-of? %List?) seqs)
          (or (null? seqs)
              (all (lambda (x)
                     (eqv? (%Length x) (%Length (car seqs))))
                   (cdr seqs))))
  (range (%List? result)
         (if (null? seqs)
           (not (%Length result))
           (eqv? (%Length result) (%Length (car seqs)))))
  (apply %Fold-left* op base seqs))

(define-with-contract (Fold-right* op base . seqs)
  "create a lazy list of right folds changing order or List items"
  (domain (procedure? op) "(op b . ss)"
          ((list-of? %List?) seqs)
          (or (null? seqs)
              (all (lambda (x)
                     (eqv? (%Length x) (%Length (car seqs))))
                   (cdr seqs))))
  (range (%List? result)
         (if (null? seqs)
           (not (%Length result))
           (eqv? (%Length result) (%Length (car seqs)))))
  (apply %Fold-right* op base seqs))

(define-with-contract (Every? ok? seq)
  "does everey item of seq fulfill ok?"
  (domain (%List? seq) (%Length seq)
          (procedure? ok?) "(ok? x)")
  (%Every? ok? seq))

(define-with-contract (Some? ok? seq)
  "does some item of seq fulfill ok?"
  (domain (%List? seq) (%Length seq)
          (procedure? ok?) "(ok? x)")
  (%Some? ok? seq))

(define-with-contract (Zip seq1 seq2)
  "interleave two lazy lists"
  (domain (%List? seq1) (%List? seq2))
  (range (%List? result)
         (if (and (%Length seq1) (%Length seq2))
           (= (%Length result)
              (+ (%Length seq1) (%Length seq2)))
           (not (%Length result))))
  (%Zip seq1 seq2))

(define lazy-lists (doclist->dispatcher (doclist)))

;; hidden
(define (all ok? lst)
  (let loop ((lst lst))
    (cond
      ((null? lst) #t)
      ((ok? (car lst))
       (loop (cdr lst)))
      (else #f))))

) ; module lazy-lists