; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2012-2017, 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.

#|[
The lazy-list implementation of this module is inspired by Moritz
Heidkamp's lazy-seq egg. It's not based on the Scheme primitives delay
and force, but uses a record type instead. I've added an additional slot
to this record-type, a boolean, finite?, so that it is possible to
discriminate between finite and infinite lazy lists without realizing
the whole record. After all, some routines, reverse for example, make
only sense for finite lists. Moreover, the names of all exported
routines are capitalized, so that I could reuse the familiar names of
eager lists without fear of name clashes.
I followed a consistent argument order, at least in principle: List
arguments are always last, procedure arguments always first. Some well
known list primitives, List-ref and List-tail, with wrong argument
order, are still there, but accompanied by At and Drop with the right
order.
]|#

(module lazy-lists
  (lazy-lists assume-in Lazy Make-lazy
   List->list list->List input->List
   First Rest Car Cdr Length Length-min Append Reverse
   List? Null? Realized? Reverse*
   List-infinite? Realize
   List-not-null? List-finite? Lists-one-finite?
   At Ref List-ref List-tail
   Take Drop Take-while Drop-while Count-while
   Memp Member Memq Memv
   Equ? Equal? Eq? Eqv?
   Assp Assoc Assq Assv
   Map Filter Sieve For-each
   Iterate Repeat Repeatedly
   Cardinals Primes Cycle Range
   Nil Cons Merge Sort Sorted? Split-at Split-with
   vector->List List->vector
   Fold-right Fold-left Fold-right* Fold-left*
   Zip Unzip Every? Some? List
   Remp Remq Remv Remove Admissible?)

(import scheme
        (only data-structures o compress list-of?)
        (only chicken
              define-record-type
              define-record-printer
              define-reader-ctor
              cut case-lambda
              unless receive
              make-parameter error void
              fixnum? fx+ fx= fx>= fx< fx> fx- fx/ fxshr))

;; documentation procedure
(define lazy-lists
  (let (
    (signatures '(
      (assume-in sym test . tests)
      (Lazy finite? xpr . xprs)
      (Make-lazy finite? thunk)
      (List->list Lst-finite)
      (list->List lst)
      (vector->List vec)
      (List->vector Lst-finite)
      (input->List port read)
      (List . args)
      ;Nil
      (Cons var Lst)
      (First Lst)
      (Rest Lst)
      (Car Lst)
      (Cdr Lst)
      (Length Lst)
      (Length-min . Lsts)
      (Append . Lsts)
      (Reverse Lst-finite)
      (Reverse* Lst)
      (List? xpr)
      (List-infinite? xpr)
      (Null? xpr)
      (List-not-null? xpr)
      (List-finite? xpr)
      (Lists-one-finite? . Lsts)
      (Every? ok? Lst)
      (Some? ok? Lst)
      (Admissible? n Lst)
      (Realized? Lst)
      (Realize Lst)
      (Split-at n Lst)
      (Split-with ok? Lst)
      (Take k Lst)
      (Drop k Lst)
      (List-tail Lst k)
      (Ref k Lst)
      (List-ref Lst k)
      (At k Lst)
      (Take-while ok? Lst)
      (Drop-while ok? Lst)
      (Count-while ok? Lst)
      (Memp ok? Lst)
      (Member val Lst)
      (Memq val Lst)
      (Memv val Lst)
      (Filter ok? Lst)
      (Remp ok? Lst)
      (Remove val Lst)
      (Remp val Lst)
      (Remv val Lst)
      (Equ? =? Lst1 Lst2)
      (Equal? Lst1 Lst2)
      (Eq? Lst1 Lst2)
      (Eqv? Lst1 Lst2)
      (Assp ok? ALst)
      (Assoc key ALst)
      (Assq key ALst)
      (Assv key ALst)
      (Map fn . Lsts)
      (For-each proc . Lsts)
      (Iterate fn x [times])
      (Repeat x [times])
      (Repeatedly thunk [times])
      (Cycle [times] Lst)
      (Range [from] upto [step])
      (Cardinals)
      (Sieve =? Lst)
      (Primes)
      (Merge <? Lst-finite1 Lst-finite2)
      (Sorted? <? Lst-finite)
      (Fold-right op base Lst . Lsts)
      (Fold-left op base Lst . Lsts)
      (Fold-right* op base Lst . Lsts)
      (Fold-left* op base Lst . Lsts)
      (Zip Lst1 Lst2)
      (Unzip Lst)
      ))
    )
    (case-lambda
      (() (cons 'Nil (map car signatures)))
      ((sym) (if (eq? sym 'Nil)
               sym
               (assq sym signatures))))))

;; internal
(define-syntax assume
  (syntax-rules ()
    ((_ sym) sym)
    ((_ sym test)
     (if test sym 'test))
    ((_ sym test . tests)
     (if test
       (assume sym . tests)
       'test))))

;;; assumptions-checked should be provided by interpreter- or
;;; compiler-switch:
;;; -feature assumptions-checked
;;; or via function call
;;; (register-feature! 'assumptions-checked)
(define-syntax assume-in
  (syntax-rules ()
    ((_ sym test . tests)
     (cond-expand
       (assumptions-checked
         (let ((res (assume sym test . tests)))
           (unless (eq? res sym)
             (error sym "Assertion failed" res))))
       (else)))))

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

(define-syntax Lazy
  (syntax-rules ()
    ((_ finite? xpr . xprs)
     (Make-lazy finite? (lambda () xpr . xprs)))))


(define (Make-lazy finite? thunk)
  (make-lazy-list finite? thunk #f))

(define (Cons var Lst)
  (assume-in 'Cons
    (List? Lst))
  (let ((finite? (lazy-list-finite? Lst)))
    (Lazy finite?
      (cons var Lst))))

(define (Length Lst)
  (assume-in 'Length
    (List? Lst))
  (if (lazy-list-finite? Lst)
    (let loop ((Lst Lst) (result 0))
      (if (Null? Lst)
        result
        (loop (Rest Lst) (fx+ 1 result))))
    #f))

(define (Length-min . Lsts)
  (assume-in 'Length-min
    ((list-of? List?) Lsts))
  (let ((Finites (compress (map lazy-list-finite? Lsts)
                            Lsts)))
    (if (null? Finites)
      #f
      (apply min (map Length Finites)))))

(define List? lazy-list?)

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

(define-record-printer (lazy-list Lst out)
  (assume-in 'define-record-printer
    (List? Lst))
  (display "#,(List[" out)
  (display (if (lazy-list-finite? Lst)
             "finite"
             "infinite") out)
  ;(display (lazy-list-finite? Lst) out)
  (display "]" out)
  (cond ((not (Realized? Lst))
         (display " ...)" out))
        ((Null? Lst)
         (display "])" out))
        (else
         (let loop ((Lst Lst))
           (if (Realized? Lst)
             (if (Null? Lst)
               (display ")" out)
               (begin
                 (display " " out)
                 (write (First Lst) out)
                 (loop (Rest Lst))))
             (display " ...)" out))))))

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

(define (Realize Lst)
  (assume-in 'Realize
    (List-finite? Lst))
  ;(let ((len (Length Lst)))
  ;  (when len
  ;    (At (fx- len 1) Lst)
  ;    Lst)))
  (At (fx- (Length Lst) 1) Lst)
  Lst)
  
(define (Realized? Lst)
  (assume-in 'Realized
    (List? Lst))
  (not (lazy-list-body Lst)))

(define (Null? xpr)
  (and (List? xpr)
       (null? (realize xpr))))

(define (First Lst)
  (assume-in 'First
    (List? Lst))
  (car (realize Lst)))

(define Car First)

(define (Rest Lst)
  (assume-in 'Rest (List? Lst))
  (cdr (realize Lst)))

(define Cdr Rest)

;; deprecated
;; makes finite Lists eager!!!
;; and if checked traverses Lists twice
(define (Admissible? n Lst)
  (assume-in 'Admissible?
    (List? Lst)
    (fixnum? n)
    (fx>= n 0))
  (let ((len (Length Lst)));(lazy-list-length Lst)))
    (or (not len) (fx< n len))))
  
(define (At k Lst)
  (assume-in 'At
    (List? Lst) (fx>= k 0))
  (cond
    ((Null? Lst)
     (error 'At "out of range" k Lst))
    ((fx= 0 k)
     (First Lst))
    (else
     (At (fx- k 1) (Rest Lst)))))

;; deprecated
(define Ref At)

(define (List-ref Lst k)
  (At k Lst))

(define (List->list Lst)
  (assume-in 'List->list
    (List-finite? Lst))
  (let loop ((lst '()) (Lst Lst))
    (if (Null? Lst)
      (reverse lst)
      (loop (cons (First Lst) lst)
            (Rest Lst)))))

(define (list->List lst)
  (assume-in 'list->List
    (list? lst))
  (let loop ((lst (reverse lst)) (Lst Nil))
    (if (null? lst)
      Lst
      (loop (cdr lst)
            (Lazy #t (cons (car lst) Lst))))))

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

(define-reader-ctor 'List List)

;; Drop and Take as well as Split-at now check n parameter
(define (Take n Lst)
  (assume-in 'Take
    (List? Lst)
    (fixnum? n)
    (fx>= n 0))
  (if (and (Null? Lst) (fx> n 0))
    (error 'Take "out of bounds" Lst n)
    (Lazy #t
      (if (or (fx= n 0) (Null? Lst))
        '()
        (cons
          (First Lst)
          (Take (fx- n 1) (Rest Lst)))))))
    
(define (Drop n Lst)
  (assume-in 'Drop
    (List? Lst)
    (fixnum? n)
    (fx>= n 0))
  (cond
    ((and (Null? Lst) (fx> n 0))
     (error 'Drop "out of bounds" Lst n))
    ((or (zero? n) (Null? Lst))
     Lst)
    (else
      (Drop (fx- n 1) (Rest Lst)))))

(define (List-tail Lst n)
  (Drop n Lst))

(define (Split-at n Lst)
  (values (Take n Lst) (Drop n Lst)))

(define (Take-while ok? Lst)
  (assume-in 'Take-while
    (List-finite? Lst)
    (procedure? ok?))
  (let ((finite? (lazy-list-finite? Lst)))
    (let loop ((Lst Lst))
      (Lazy finite?
        (cond
          ((Null? Lst)
           '())
          ((ok? (First Lst))
           (cons (First Lst) (loop (Rest Lst))))
          (else '()))))))
;  (Lazy (lazy-list-finite? Lst)
;    (let loop ((Lst Lst))
;      (cond
;        ((Null? Lst)
;         '())
;        ((ok? (First Lst))
;         (cons (First Lst) (loop (Rest Lst))))
;        (else '())))))

(define (Count-while ok? Lst)
  (assume-in 'Count-while
    (List-finite? Lst)
    (procedure? ok?))
  (let loop ((Lst Lst) (index 0))
    (cond
      ((Null? Lst)
       index)
      ((ok? (First Lst))
       (loop (Rest Lst) (fx+ index 1)))
      (else index))))

(define (Drop-while ok? Lst)
  (assume-in 'Drop-while
    (List-finite? Lst)
    (procedure? ok?))
  (let ((finite? (lazy-list-finite? Lst)))
    (let loop ((Lst Lst))
      (Lazy finite?
        (cond
          ((Null? Lst)
           '())
          ((ok? (First Lst))
           (loop (Rest Lst)))
          (else Lst))))))

(define (Split-with ok? Lst)
  (values (Take-while ok? Lst)
          (Count-while ok? Lst)
          (Drop-while ok? Lst)))

(define (Memp ok? Lst)
  (assume-in 'Memp
    (List-finite? Lst)
    (procedure? ok?))
  (Drop-while (o not ok?) Lst))

(define (Memq var Lst)
  ;(assume-in 'Memq
  ;  (List-finite? Lst))
  (Memp (cut eq? <> var) Lst))

(define (Memv var Lst)
  ;(assume-in 'Memv
  ;  (List-finite? Lst))
  (Memp (cut eqv? <> var) Lst))

(define (Member var Lst)
  ;(assume-in 'Member
  ;  (List-finite? Lst))
  (Memp (cut equal? <> var) Lst))

(define (Equ? =? Lst1 Lst2)
  (assume-in 'Equ?
    (procedure? =?)
    (List? Lst1)
    (List? Lst2))
  (cond
    ((and (List-finite? Lst1) (List-finite? Lst2)) 
     (let loop ((Lst1 Lst1) (Lst2 Lst2))
       (cond
         ((and (Null? Lst1) (Null? Lst2))
          #t)
         ((=? (First Lst1) (First Lst2))
          (loop (Rest Lst1) (Rest Lst2)))
         (else #f))))
    ((and (List-infinite? Lst1) (List-infinite? Lst2))
     (eq? Lst1 Lst2))
    (else #f)))

(define (Eq? Lst1 Lst2)
  ;(assume-in 'Eq?
  ;  (List? Lst1)
  ;  (List? Lst2))
  (Equ? eq? Lst1 Lst2))

(define (Eqv? Lst1 Lst2)
  ;(assume-in 'Eqv?
  ;  (List? Lst1)
  ;  (List? Lst2))
  (Equ? eqv? Lst1 Lst2))

(define (Equal? Lst1 Lst2)
  ;(assume-in 'Equal?
  ;  (List? Lst1)
  ;  (List? Lst2))
  (Equ? equal? Lst1 Lst2))

(define (Assp ok? al)
  (assume-in 'Assp
    (procedure? ok?)
    ((list-of? pair?) al))
  (let (
    (Lst (Drop-while (lambda (pair) (not (ok? (car pair)))) al))
    )
    (if (Null? Lst) #f (First Lst))))

(define (Assq key al)
  ;(assume-in 'Assq
  ;  ((list-of? pair?) al))
  (Assp (cut eq? <> key) al))

(define (Assv key al)
  ;(assume-in 'Assv
  ;  ((list-of? pair?) al))
  (Assp (cut eqv? <> key) al))

(define (Assoc key al)
  ;(assume-in 'Assoc
  ;  ((list-of? pair?) al))
  (Assp (cut equal? <> key) al))

;; internal
(define (memp ok? lst)
  (let loop ((lst lst))
    (cond
      ((null? lst) #f)
      ((ok? (car lst)) lst)
      (else
        (loop (cdr lst))))))

(define (Map proc . Lsts)
  (assume-in 'Map
    (procedure? proc)
    ((list-of? List?) Lsts))
  (if (null? Lsts)
    Nil
    (let ((finite? (if (not (apply Length-min Lsts)) #f #t)))
      (let loop ((Lsts Lsts))
        (Lazy finite?
          (if (memp Null? Lsts)
            '()
            (cons (apply proc (map Car Lsts))
                  (loop (map Cdr Lsts)))))))))

(define (For-each proc . Lsts)
  (assume-in 'For-each
    (procedure? proc)
    (apply Lists-one-finite? Lsts))
  (if (null? Lsts)
    (void)
    (let ((len (apply Length-min Lsts)))
      (do ((Lsts Lsts (map Cdr Lsts)) (k 0 (fx+ k 1)))
        ((fx= k len))
        (apply proc (map Car Lsts))))))

(define (Unzip Lst)
  (assume-in 'Unzip
    (List? Lst))
  (let ((ev? #f))
    (let ((finite? (lazy-list-finite? Lst)))
      (let loop ((Lst Lst))
        (cond
          ((Null? Lst)
           (values Nil Nil))
          (else
            (set! ev? (not ev?))
            (if ev?
              (values (Lazy finite?
                        (cons (First Lst) (loop (Rest Lst))))
                      (Lazy finite?
                        (loop (Rest Lst))))
              (values (Lazy finite?
                        (loop (Rest Lst)))
                      (Lazy finite?
                        (cons (First Lst) (loop (Rest Lst))))))))))))
   
(define (Zip Lst1 Lst2)
  (assume-in 'Zip
    (List? Lst1)
    (List? Lst2))
  (let ((both-finite?
          (and (lazy-list-finite? Lst1)
               (lazy-list-finite? Lst2))))
    (let loop ((Lst1 Lst1) (Lst2 Lst2))
      (if (Null? Lst1)
        Lst2
        (Lazy both-finite?
          (cons (First Lst1) (loop Lst2 (Rest Lst1))))))))

(define (Filter ok? Lst)
  (assume-in 'Filter
    (List? Lst)
    (procedure? ok?))
    (let ((finite? (lazy-list-finite? Lst)))
      (let loop ((Lst Lst))
        (Lazy finite?
          (if (Null? Lst)
            '()
            (let ((first (First Lst)) (rest (Rest Lst)))
              (if (ok? first)
                (cons first (loop rest))
                (loop rest))))))))

(define (Remp ok? Lst)
  (Filter (o not ok?) Lst))

(define (Remove val Lst)
  (Remp (cut equal? <> val) Lst))

(define (Remq val Lst)
  (Remp (cut eq? <> val) Lst))

(define (Remv val Lst)
  (Remp (cut eqv? <> val) Lst))

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

(define Repeat
  (case-lambda
    ((x) (Lazy #f (cons x (Repeat x))))
    ((x times)
     (assume-in 'Repeat
       (fixnum? times)
       (fx>= times 0))
     (Take times (Repeat x)))))

(define Repeatedly
  (case-lambda
    ((thunk)
     (assume-in 'Repeatedly
       (procedure? thunk))
     (Lazy #f (cons (thunk) (Repeatedly thunk))))
    ((thunk times)
     (assume-in 'Repeatedly
       (fixnum? times)
       (fx>= times 0))
     (Take times (Repeatedly thunk)))))

(define Iterate
  (case-lambda
    ((fn x)
     (assume-in 'Iterate
       (procedure? fn))
     (Lazy #f (cons x (Iterate fn (fn x)))))
    ((fn x times)
     (assume-in 'Iterate
       (fixnum? times)
       (fx>= times 0))
     (Take times (Iterate fn x)))))

(define Cycle
  (case-lambda
    ((Lst)
     (assume-in 'Cycle
       (List? Lst))
     (if (Null? Lst)
       Nil
       (let loop ((tail Lst))
         (Lazy #f
           (if (Null? tail)
             (loop Lst)
             (cons (First tail)
                   (loop (Rest tail))))))))
    ((n Lst)
     (assume-in 'Cycle
       (fixnum? n)
       (fx>= n 0))
     (Take n (Cycle Lst)))))

(define Range
  (case-lambda
    ((upto)
     (Iterate (if (fx>= upto 0)
                (cut fx+ <> 1)
                (cut fx- <> 1))
              0
              (abs upto)))
    ((from upto)
     (Iterate (if (fx>= upto from)
                      (cut fx+ <> 1)
                      (cut fx- <> 1))
              from
              (abs (fx- upto from))
              ))
    ((from upto step)
     (Iterate (if (fx>= upto from)
                      (cut fx+ <> step)
                      (cut fx- <> step))
              from
              (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step)
              ))))

(define Append
  (case-lambda
    ((Lst1 Lst2)
     (assume-in 'Append
       (List? Lst1) (List? Lst2))
     (if (List-infinite? Lst1)
       Lst1
       (let ((finite? (lazy-list-finite? Lst2)))
         (let loop ((Lst1 Lst1))
           (Lazy finite?
             (if (Null? Lst1)
               Lst2
               (cons (First Lst1) (loop (Rest Lst1)))))))))
    ((Lst . Lsts)
     (if(Null? Lsts)
       Lst
       (apply Append
              (Append Lst (First Lsts))
              (Rest Lsts))))
    ))

(define Reverse
  (case-lambda
    ((Lst1 Lst2)
     (assume-in 'Reverse
       (List-finite? Lst1) (List? Lst2))
     (let ((finite? (lazy-list-finite? Lst2)))
       (let loop ((Lst1 Lst1) (Result Lst2))
         (if (Null? Lst1)
           Result
           (loop (Rest Lst1)
                 (Lazy finite?
                   (cons (First Lst1) Result)))))))
    ((Lst)
     (Reverse Lst Nil))))

(define (Reverse* Lst)
  (assume-in 'Reverse*
    (List? Lst))
  (let ((finite? (lazy-list-finite? Lst)))
    (if (not finite?)
      (let loop ((n 1))
        (Lazy #f (cons (Reverse (Take n Lst))
                       (loop (fx+ n 1)))))
      (let ((len (Length Lst)))
        (let loop ((n 1))
          (Lazy #t
            (if (fx= 0 len)
              (list (First Lst))
              (cons (Reverse (Take n Lst))
                    (loop (fx+ n 1))))))))))

(define (Merge <? Lst1 Lst2)
  (assume-in 'Merge
    (procedure? <?)
    (List-finite? Lst1)
    (List-finite? Lst2))
  (let loop ((Lst1 Lst1) (Lst2 Lst2))
    (cond
      ((Null? Lst1) Lst2)
      ((Null? Lst2) Lst1)
      ((<? (First Lst1) (First Lst2))
       (Lazy #t
         (cons (First Lst1) (loop (Rest Lst1) Lst2))))
      (else 
       (Lazy #t
             (cons (First Lst2) (loop Lst1 (Rest Lst2))))))))

(define (Sort <? Lst)
  (assume-in 'Sort
    (procedure? <?)
    (List-finite? Lst))
  (let ((len (Length Lst)))
    (if (fx< len 2)
      Lst
      (let ((halflen (fxshr len 1)))
        (Merge <?
          (Sort <? (Take halflen Lst))
          (Sort <? (Drop halflen Lst)))))))

(define (Sorted? <? Lst)
  (assume-in 'Sorted?
    (procedure? <?)
    (List-finite? Lst))
  (let loop ((Lst Lst))
    (cond
      ((Null? Lst) #t)
      ((Null? (Rest Lst)) #t)
      ((<? (First Lst) (First (Rest Lst)))
       (loop (Rest Lst)))
      (else #f))))

(define (vector->List vec)
  (assume-in 'vector->List
    (vector? vec))
  (let loop ((Result Nil) (n (fx- (vector-length vec) 1)))
    (if (fx< n 0)
      Result
      (loop (Lazy #t (cons (vector-ref vec n) Result))
            (fx- n 1))))) 
(define (List->vector Lst)
  (assume-in 'List->vector
    (List-finite? Lst))
  (let* ((len (Length Lst)) (vec (make-vector len #f)))
    (do ((k 0 (fx+ k 1)) (Lst Lst (Rest Lst)))
      ((fx= k len) vec)
      (vector-set! vec k (First Lst)))))

(define (Sieve =? Lst)
  (assume-in 'Sieve
    (procedure? =?)
    (List? Lst))
  (let ((finite? (lazy-list-finite? Lst)))
    (let loop ((Lst Lst))
      (Lazy finite?
        (if (Null? Lst)
          '()
          (let (
            (first (First Lst))
            (rest
              (Filter
                (lambda (x)
                  (not (=? x (First Lst))))
                (Rest Lst)))
            )
            (cons first (loop rest))))))))

(define (Fold-left op base Lst . Lsts)
  (assume-in 'Fold-left
    (procedure? op)
    (List? Lst)
    (or (List-finite? Lst) (apply Lists-one-finite? Lsts)))
  (let* ((Lsts (cons Lst Lsts)) (len (apply Length-min Lsts)))
    (let loop ((Lsts Lsts) (k 0) (result base))
      (if (fx= k len)
        result
        (loop (map Cdr Lsts)
              (fx+ k 1)
              (apply op result (map Car Lsts)))))))

(define (Fold-right op base Lst . Lsts)
  (assume-in 'Fold-right
    (procedure? op)
    (List? Lst)
    (or (List-finite? Lst) (apply Lists-one-finite? Lsts)))
  (let* ((Lsts (cons Lst Lsts)) (len (apply Length-min Lsts)))
    (let loop ((Lsts Lsts) (len len))
      (if (fx= 0 len)
        base
        (apply op 
               (append (map First Lsts)
                       (list (loop (map Rest Lsts) (fx- len 1)))))))))

;;; The following two routines return Lists
(define (Fold-left* op base Lst . Lsts)
  (assume-in 'Fold-left*
    (procedure? op)
    (List? Lst)
    ((list-of? List?) Lsts))
  (let* ((Lsts (cons Lst Lsts))
         (finite? (if (not (apply Length-min Lsts))
                    #f
                    #t)))
    (letrec (
      (fold
        (Lazy finite?
          (cons base
                (apply Map op
                       (Lazy finite? fold)
                       Lsts))))
      )
      (Rest fold))))

(define (Fold-right* op base Lst . Lsts) ; changes order of List items
  (assume-in 'Fold-right*
    (procedure? op)
    (List? Lst)
    ((list-of? List?) Lsts))
  (let* ((Lsts (cons Lst Lsts))
         (finite? (if (not (apply Length-min Lsts))
                    #f
                    #t)))
      (letrec (
        (fold
          (Lazy finite?
            (cons base
                  (apply Map op
                         (append Lsts
                                 (list
                                   (Lazy finite? fold)))))))
        )
        (Rest fold))))

(define (Every? ok? Lst)
  (assume-in 'Every?
    (procedure? ok?)
    (List-finite? Lst))
  (let loop ((Lst Lst))
    (cond
      ((Null? Lst) #t)
      ((ok? (First Lst))
       (loop (Rest Lst)))
      (else #f))))

(define (Some? ok? Lst)
  (assume-in 'Some?
    (procedure? ok?)
    (List-finite? Lst))
  (let loop ((Lst Lst))
    (cond
      ((Null? Lst) #f)
      ((ok? (First Lst)) #t)
      (else
        (loop (Rest Lst))))))

(define (List-not-null? xpr)
  (and (List? xpr)
       (not (Null? xpr))))

(define (List-finite? xpr)
  (and (List? xpr) ; (if (Length xpr) #t #f)))
       (lazy-list-finite? xpr)))

(define (List-infinite? xpr)
  (and (List? xpr) ;(if (Length xpr) #f #t)))
       (not (lazy-list-finite? xpr))))

(define (Lists-one-finite? . Lsts)
  (assume-in 'List-one-finite?
    (not (null? Lsts))
    ((list-of? List?) Lsts))
  ;(if (apply Length-min Lsts) #t #f))
  (not (null? (compress (map lazy-list-finite? Lsts)
                        Lsts))))

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

) ; module lazy-lists