; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2013-2019, 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 dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser 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.


#|[
This is another implementation of lazy-lists. Contrary to other
implementations this one
-- is able to distinguish between finite and infinite lazy lists
-- implements most routines so that they can be used as partial routines
-- all routines are named with uppercase first letter, so that
   they don't conflict with equally named standard list routines
-- arguments have standard orders:
   procedure arguments first, biglist arguments last
]|#

(module biglists (
  Append
  Assoc
  Assp
  Assq
  Assv
  At
  BigList?
  BigList->list
  Collect
  Cons
  Cycle
  Cycle-times
  Drop
  Drop-while
  Drop-until
  Eager?
  Eq?
  Eqp?
  Equal?
  Eqv?
  Every?
  Filter
  Fold-left
  Fold-left0
  Fold-right
  Fold-right0
  For-each
  First
  Index
  Iterate
  Iterate-times
  Iterate-until
  Iterate-while
  Lazy?
  Length
  List
  List?
  List-of?
  Map
  Member
  Memp
  Memq
  Memv
  Merge
  Null?
  Print
  Range
  Read-forever
  Remove
  Remp
  Remq
  Remv
  Repeat
  Repeat-times
  Rest
  Reverse
  Reverse*
  Scan-left
  Scan-right
  Some?
  Sort
  Sorted?
  Take
  Take-until
  Take-while
  Unzip
  Zip
  biglist-lazy
  biglists
  eos
  )


  (import scheme (chicken base) (only bindings eos bind-seq-db))

(define (and? . xprs)
  (call/cc
    (lambda (out)
      (for-each (lambda (x) (or x (out #f)))
                xprs)
      #t)))

(define-record-type lazy
  (biglist-lazy first rest finite?)
  lazy?
  (first lazy-first)
  (rest lazy-rest)
  (finite? lazy-finite?))

(define-record-printer (lazy xs out)
  (let ((start "(Lazy[") (stop ")"))
    (display start out)
    (display (if (List? xs)
               "finite"
               "infinite") out)
    (display "]" out)
    (cond ((and (Lazy? xs) (List? xs))
           (let loop ((xs xs))
             (if (Null? xs)
               (display stop out)
               (begin
                 (display " " out)
                 (write (First xs) out)
                 (loop (Rest xs))))))
           ((and (Lazy? xs) (not (List? xs)))
            (let loop ((k 0) (xs xs))
              (cond
                ((= k 10)
                 (display " ..." out)
                 (display stop out))
                (else
                  (display " " out)
                  (write (First xs) out)
                  (loop (+ k 1) (Rest xs)))))))))

(define-syntax Cons
  (syntax-rules ()
    ((_ x y finite?)
     (biglist-lazy (delay x) (delay y) finite?))
    ((_ x y) (cons x y))
    ))

(define (BigList? xpr)
  (or
    (list? xpr)
    (eq? xpr eos) ;;;;;;
    (and (lazy? xpr)
         (promise? (lazy-first xpr))
         (promise? (lazy-rest xpr))
         (boolean? (lazy-finite? xpr)))
    ))

(define Eager? list?)

(define (Lazy? xpr) 
  (and (BigList? xpr) (not (list? xpr))))

(define (List? xpr) ; finite
  (or (eq? xpr eos)
      (Eager? xpr)
      (and (Lazy? xpr)
           (lazy-finite? xpr))))

(define List-of?
  (case-lambda
    (oks?
      (lambda (xpr)
        (apply and?
               (List? xpr)
               (BigList->list
                 (Map (lambda (x)
                        (apply and?
                               (map (lambda (ok?) (ok? x))
                                    oks?)))
                      xpr)))))
    ((k . oks?)
     (lambda (xpr)
       (and (BigList? xpr)
            ((apply List-of? oks?)
             (Take k xpr)))))
    ))

(define (Null? xs) 
  (and (BigList? xs)
       (or (eqv? xs '())
           (eq? xs eos))))

(define (First xs)
  (cond
    ((Eager? xs)
     (if (null? xs)
       eos
       (car xs)))
    ((Lazy? xs)
     (if (Null? xs)
       eos
       (force (lazy-first xs))))
    (else (error 'First "not a biglist" xs))))

(define (Rest xs)
  (cond
    ((list? xs)
     (if (null? xs)
       '()
       (cdr xs)))
    ((Lazy? xs)
     (if (Null? xs)
       xs
       (force (lazy-rest xs))))
    (else (error 'Rest "not a biglist" xs))))

(define (Length xs)
  (if (BigList? xs)
    (cond
      ((Eager? xs) (length xs))
      ((List? xs)
       (if (Null? xs)
         0
         (+ 1 (Length (Rest xs)))))
      (else #f))
    (error 'Length "not a biglist" xs)
    ))


(define (At n . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (At n xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (if (BigList? xs)
         (if (zero? n)
           (First xs)
           (At (- n 1) (Rest xs)))
         (error 'At "not a biglist" xs))))
    (else (error 'At "too many arguments"))))

(define (List . args)
  (if (null? args)
    eos
    (Cons (car args)
          (apply List (cdr args))
          #t)))

(define (Take k . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Take k xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (if (BigList? xs)
         (let ((eager? (Eager? xs)))
           (cond
             ((Null? xs) xs)
             ((zero? k) (if eager? '() eos))
             (else
               (if eager?
                 (Cons (First xs) (Take (- k 1) (Rest xs)))
                 (Cons (First xs) (Take (- k 1) (Rest xs)) #t)))))
         (error 'Take "not a biglist" xs))))
;       (cond
;         ((Eager? xs)
;          (if (zero? k)
;            '()
;            (Cons (First xs) (Take (- k 1) (Rest xs)))))
;         ((Lazy? xs)
;          (if (zero? k)
;            eos
;            (Cons (First xs) (Take (- k 1) (Rest xs)) #t)))
;         (else (error 'Take "not a biglist" xs)))))
    (else (error 'Take "too many arguments"))))

(define (Take-while ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Take-while ok? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (cond
         ((Eager? xs)
          (let recur ((xs xs))
            (cond
              ((null? xs) xs)
              ((ok? (First xs))
               (Cons (First xs) (recur (Rest xs))))
              (else '()))))
         ((Lazy? xs)
          (let recur ((xs xs))
            (if (ok? (First xs))
              (Cons (First xs) (recur (Rest xs)) #t)
              eos)))
         (else (error 'Take-while "not a biglist" xs)))))
    (else (error 'Take-while "too many arguments"))))

(define (Take-until ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Take-while ok? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (cond
         ((Eager? xs)
          (let recur ((xs xs))
            (cond
              ((null? xs) xs)
              ((ok? (First xs)) '())
              (else
                (Cons (First xs) (recur (Rest xs)))))))
         ((Lazy? xs)
          (let recur ((xs xs))
            (cond
              ((Null? xs) xs)
              ((ok? (First xs))
               eos)
              (else
                (Cons (First xs) (recur (Rest xs)) #t)))))
         (else (error 'Take-until "not a biglist" xs)))))
    (else (error 'Take-while "too many arguments"))))

(define (Drop k . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Drop k xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (if (BigList? xs)
         (if (zero? k)
           xs
           (Drop (- k 1) (Rest xs)))
         (error 'Drop "not a biglist" xs))))
    (else (error 'Drop "too many arguments"))))

(define (Drop-while ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Drop-while ok? xs)))
    ((null? (cdr xss))
     (let* ((xs (car xss))
            (nil (cond
                   ((Eager? xs) '())
                   ((Lazy? xs) eos)
                   (error 'Drop-while "not a biglist" xs))))
       (let loop ((xs xs))
         (cond
           ((Null? xs) nil)
           ((ok? (First xs))
            (loop (Rest xs)))
           (else xs)))))
    (else (error 'Drop-while "too many arguments"))))

(define (Drop-until ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Drop-while ok? xs)))
    ((null? (cdr xss))
     (let* ((xs (car xss))
            (nil (cond
                   ((Eager? xs) '())
                   ((Lazy? xs) eos)
                   (error 'Drop-until "not a biglist" xs))))
       (let loop ((xs xs))
         (cond
           ((Null? xs) nil)
           ((ok? (First xs)) xs)
           (else (loop (Rest xs)))))))
    (else (error 'Drop-until "too many arguments"))))

(define BigList->list
  (case-lambda
    ((xs)
     (if (List? xs)
       (BigList->list (Length xs) xs)
       (error 'BigList->list "not a biglist" xs)))
    ((k . xss)
     (cond
       ((null? xss)
        (lambda (xs)
          (BigList->list k xs)))
       ((null? (cdr xss))
        (let ((xs (car xss)))
          (cond
            ((Eager? xs) xs)
            ((Lazy? xs)
             (let recur ((n 0) (xs xs))
               (cond
                 ((Null? xs) '())
                 ((= n k) '())
                 (else
                   (Cons (First xs)
                         (recur (+ n 1) (Rest xs)))))))
            (else (error 'BigList->list "not a biglist" xs)))))
       (else
         (error 'BigList->list "too many arguments"))))
    ))

(define (Filter ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Filter ok? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
;      ;; this version is inefficient:
;      ;; it checks for Eager again and again
;      (if (BigList? xs)
;         (let recur ((xs xs))
;           (cond
;             ((Null? xs)
;              (if (Eager? xs) '() eos))
;             ((ok? (First xs))
;              (if (Eager? xs)
;                (Cons (First xs) (recur (Rest xs)))
;                (Cons (First xs)
;                      (recur (Rest xs))
;                      (List? xs))))
;             (else (recur (Rest xs)))))
;         (error 'Filter "not a biglist" xs))))
       (cond
         ((Eager? xs)
          (let recur ((xs xs))
            (cond
              ((Null? xs) xs)
              ((ok? (First xs))
               (Cons (First xs) (recur (Rest xs))))
              (else (recur (Rest xs))))))
         ((Lazy? xs)
          (let recur ((xs xs))
            (cond
              ((Null? xs) eos);xs)
              ((ok? (First xs))
               (Cons (First xs)
                     (recur (Rest xs))
                     (List? xs)))
              (else (recur (Rest xs))))))
         (else
           (error 'Filter "not a biglist" xs)))))
    (else
      (error 'Filter "too many arguments"))
    ))

(define (Map fn . xss)
  (if (null? xss)
    (lambda lists
      (apply Map fn lists))
    (let ((xs (car xss)))
      (cond
        ((Eager? xs)
         (if ((list-of? BigList?) (cdr xss))
           (let recur ((xss xss))
             (if (memv #t (map Null? xss))
               '()
               (cons (apply fn (map First xss))
                     (recur (map Rest xss)))))
           (error 'Map "not a list of biglists" xss)))
        ((Lazy? xs)
         (if ((list-of? BigList?) (cdr xss))
           (let recur ((xss xss))
             (if (memv #t (map Null? xss))
               eos
               (Cons (apply fn (map First xss))
                     (recur (map Rest xss))
                     (and? (map List? xss)))))
           (error 'Map "not a list of biglists" xss)))
        (else
          (error 'Map "not a biglists" xs))
        ))
    ))

(define (For-each fn . xss)
  (if ((list-of? BigList?) xss)
    (if (null? xss)
      (lambda lists
        (apply For-each fn lists))
      (unless (memq #t (map Null? xss))
        (cond
          (((list-of? Eager?) xss)
           (apply fn (map First xss))
           (apply For-each fn (map Rest xss)))
          (((list-of? Lazy?) xss)
           (apply fn (map First xss))
           (apply For-each fn (map Rest xss)))
          (else
            (error 'For-each "not all either eager or lazy" xss))
          )))
    (error 'For-each "not a list of biglists" xss)
    ))

(define (Append xs . xss)
  (if (BigList? xs)
    (cond
      ((null? xss) xs)
      ((null? (cdr xss))
       (let ((ys (First xss)))
         (cond
           ((and (List? xs) (Eager? ys))
            (if (Null? xs)
              ys
              (Cons (First xs) (Append (Rest xs) ys))))
           ((and (List? xs) (BigList? ys))
            (if (Null? xs)
              ys
              (Cons (First xs)
                       (Append (Rest xs) ys)
                       (List? ys))))
           (else
             (error 'Append "invalid arguments" xs ys)))))
      (else
        (Append xs (apply Append (car xss) (cdr xss)))))
    (error 'Append "not a biglist" xs)))

(define (Reverse xs . xss)
  (cond
    ((null? xss)
     (cond
       ((Eager? xs)
        (Reverse xs '()))
       ((List? xs)
        (Reverse xs eos))
       (else (error "not a finite biglist" xs))))
    ((null? (cdr xss))
     (let ((ys (car xss)))
       (cond
         ((and (Eager? xs) (Eager? ys))
          (let loop ((xs xs) (result ys))
            (if (Null? xs)
              result
              (loop (Rest xs)
                    (Cons (First xs) result)))))
         ((and (List? xs) (Eager? ys))
          (let loop ((xs xs) (result ys))
            (if (Null? xs)
              result
              (loop (Rest xs)
                    (Cons (First xs) result)))))
         ((and (Eager? xs) (BigList? ys))
          (let loop ((xs xs) (result ys))
            (if (Null? xs)
              result
              (loop (Rest xs)
                    (Cons (First xs) result (List? ys))))))
         ((and (List? xs) (BigList? ys))
          (let loop ((xs xs) (result ys))
            (if (Null? xs)
              result
              (loop (Rest xs)
                    (Cons (First xs) result (List? ys))))))
         (else
           (error 'Reverse "invalid arguments" xs ys)))))
    (else (error 'Reverse "too many arguments"))))

(define (Reverse* xs)
  (cond
    ((Eager? xs)
     (let recur ((k 0))
       (if (> k (Length xs))
         '()
         (Cons (Reverse (Take k xs)) (recur (+ k 1))))))
    ((BigList? xs)
     (let recur ((k 0))
       (cond
         ((not (Length xs))
          (Cons (Reverse (Take k xs))
                   (recur (+ k 1))
                   #f))
         (else 
           (if (> k (Length xs))
             eos
             (Cons (Reverse (Take k xs))
                      (recur (+ k 1))
                      #t))
           ))))
    (else (error 'Reverse* "not a biglist" xs))))

(define (Zip xs ys)
  (cond
    ((and (Eager? xs) (Eager? ys))
     (let recur ((xs xs) (ys ys))
       (if (Null? xs)
         ys
         (Cons (First xs) (recur ys (Rest xs))))))
    ((and (BigList? xs) (BigList? ys))
     (let recur ((xs xs) (ys ys))
       (if (Null? xs)
         ys
         (Cons (First xs)
                  (recur ys (Rest xs))
                  (and (List? xs) (List? ys))))))
    (else
      (error 'Zip "invalid arguments" xs ys))))

(define (Unzip xs)
  (cond
    ((Eager? xs)
     (let ((one
             (let ((ev? #f))
               (let recur ((xs xs))
                 (cond
                   ((Null? xs) '())
                   (else
                     (set! ev? (not ev?))
                     (if ev?
                       (Cons (First xs) (recur (Rest xs)))
                       (recur (Rest xs))
                       ))))))
           (two
             (let ((ev? #f))
               (let recur ((xs xs))
                 (cond
                   ((Null? xs) '())
                   (else
                     (set! ev? (not ev?))
                     (if ev?
                       (recur (Rest xs))
                       (Cons (First xs) (recur (Rest xs))))))))))
       (values one two)))
    ((BigList? xs)
     (let ((finite? (List? xs)))
       (let ((one
               (let ((ev? #f))
                 (let recur ((xs xs))
                   (cond
                     ((Null? xs) eos)
                     (else
                       (set! ev? (not ev?))
                       (if ev?
                         (Cons (First xs) (recur (Rest xs)) finite?)
                         (recur (Rest xs))
                         ))))))
             (two
               (let ((ev? #f))
                 (let recur ((xs xs))
                   (cond
                     ((Null? xs) eos)
                     (else
                       (set! ev? (not ev?))
                       (if ev?
                         (recur (Rest xs))
                         (Cons (First xs) (recur (Rest xs)) finite?))))))))
         (values one two))))
    (else (error 'Unzip "not a biglist" xs))))

(define (Sorted? <? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Sorted? <? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (if (List? xs)
         (let loop ((xs xs))
           (cond
             ((Null? xs) #t)
             ((Null? (Rest xs)) #t)
             ((<? (First xs) (First (Rest xs)))
              (loop (Rest xs)))
             (else #f)))
         (error 'Sorted? "not a finite biglist" xs))))
    (else (error 'Sorted? "too many arguments"))))

(define (Merge <? xs ys)
  (if (and (Sorted? xs) (Sorted? ys))
    (cond
      ((and (Eager? xs) (Eager? ys))
       (let recur ((xs xs) (ys ys))
         (cond
           ((Null? xs) ys)
           ((Null? ys) xs)
           ((<? (First xs) (First ys))
            (Cons (First xs) (recur (Rest xs) ys)))
           (else 
             (Cons (First ys) (recur xs (Rest ys)))))))
      ((and (Lazy? xs) (Lazy? ys))
       (let recur ((xs xs) (ys ys))
         (cond
           ((Null? xs) ys)
           ((Null? ys) xs)
           ((<? (First xs) (First ys))
            (Cons (First xs) (recur (Rest xs) ys) #t))
           (else 
             (Cons (First ys) (recur xs (Rest ys)) #t)))))
      (else (error 'Merge "arguments not both lazy or eager" xs ys)))
    (error 'Merge "arguments not sorted" xs ys)))

(define (Sort <? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Sort <? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (if (List? xs)
         (let* ((xs xs) (len (Length xs)))
           (if (< len 2)
             xs
             (let ((halflen (round (/ len 2))))
               (Merge <?
                      (Sort <? (Take halflen xs))
                      (Sort <? (Drop halflen xs))))))
         (error 'Sort "not a finite biglist" xs))))
    (else (error 'Sort "too many arguments"))))

(define (Every? ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Every? ok? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (if (List? xs)
         (let loop ((xs xs))
           (cond
             ((Null? xs) #t)
             ((ok? (First xs))
              (loop (Rest xs)))
             (else #f)))
         (error 'Every? "not a finite biglist" xs))))
    (else (error 'Every? "too many arguments"))))

(define (Some? ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Some? ok? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (if (List? xs)
         (let loop ((xs xs))
           (cond
             ((Null? xs) #f)
             ((ok? (First xs)) #t)
             (else
               (loop (Rest xs)))))
         (error 'Some? "not a finite biglist" xs))))
    (else (error 'Some? "too many arguments"))))

(define (Index ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Index ok? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (if (BigList? xs)
         (let loop ((xs xs) (k 0))
           (cond
             ((Null? xs) #f)
             ((ok? (First xs)) k)
             (else (loop (Rest xs) (+ k 1)))))
         (error 'Index "not a biglist" xs))))
    (else (error 'Index "too many arguments"))))

(define (Memp ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Memp ok? xs)))
    ((null? (cdr xss))
     (if (BigList? (car xss))
       (let* ((xs (car xss))
              (nil (cond
                     ((Eager? xs) '())
                     ((Lazy? xs) eos)
                     (else (error 'Memp "not a biglist" xs)))))
         (let loop ((xs xs))
           (cond
             ((Null? xs) nil)
             ((ok? (First xs)) xs)
             (else (loop (Rest xs))))))))
    (else (error 'Memp "too many arguments"))))

(define (Memq var . xss)
  (apply Memp (cut eq? <> var) xss))

(define (Memv var . xss)
  (apply Memp (cut eqv? <> var) xss))

(define (Member var . xss)
  (apply Memp (cut equal? <> var) xss))

(define Eqp?
  (case-lambda
    ((=?)
     (lambda (xs ys)
       (Eqp? =? xs ys)))
    ((=? xs ys)
     (cond
       ((and (Eager? xs) (Lazy? ys)) #f)
       ((and (Lazy? xs) (Eager? ys)) #f)
       ((not (eqv? (Length xs) (Length ys))) #f) 
       ((and (List? xs) (List? ys))  
        (let loop ((xs xs) (ys ys))
          (cond
            ((and (Null? xs) (Null? ys))
             #t)
            ((=? (First xs) (First ys))
             (loop (Rest xs) (Rest ys)))
            (else #f))))
       ((and (BigList? xs) (BigList? ys))
        (eqv? xs ys))
       (else (equal? xs ys))))
    ))

(define Eq? (Eqp? eq?))
(define Eqv? (Eqp? eqv?))
(define Equal? (Eqp? equal?))

(define (Assp ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs)
       (Assp ok? xs)))
    ((null? (cdr xss))
     (let ((xs (car xss)))
       (cond
         (((List-of? BigList?) xs)
          (let loop ((xs xs))
            (cond
              ((Null? xs) #f)
              ((ok? (First (First xs)))
               (First xs))
              (else (loop (Rest xs))))))
         (else (error 'Assp "not a finite biglist" xs)))))
    (else (error 'Assp "too many arguments"))
    ))

(define (Assq key . xss)
  (apply Assp (cut eq? <> key) xss))

(define (Assv key . xss)
  (apply Assp (cut eqv? <> key) xss))

(define (Assoc key . xss)
  (apply Assp (cut equal? <> key) xss))

(define (Remp ok? . xss)
  (cond
    ((null? xss)
     (lambda (xs) (Remp ok? xs)))
    ((null? (cdr xss))
     (Filter (o not ok?) (car xss)))
    (else (error 'Remp "too many arguements"))))

(define (Remove val . xss)
  (apply Remp (cut equal? <> val) xss))

(define (Remq val . xss)
  (apply Remp (cut eq? <> val) xss))

(define (Remv val . xss)
  (apply Remp (cut eqv? <> val) xss))

(define (Fold-right op init . xss)
  (cond
    ((null? xss)
     (lambda pairs
       (apply Fold-right op init pairs)))
    (else
      (if ((list-of? BigList?) xss)
        (let recur ((xss xss))
          (if (memv #t (map List? xss))
            (cond
              ((memv #t (map Null? xss)) init)
              (else
                (apply op
                       (append (map First xss)
                               (list (recur (map Rest xss)))))))
            (error 'Fold-right "all biglists infinite")))
        (error 'Fold-right "not a list of biglists" xss)))
      ))

(define (Fold-left op init . xss)
  (cond
    ((null? xss)
     (lambda pairs
       (apply Fold-left op init pairs)))
    (else
      (if ((list-of? BigList?) xss)
        (let loop ((xss xss) (result init))
          (if (memv #t (map List? xss))
            (cond
              ((memv #t (map Null? xss)) result)
              (else
                (loop (map Rest xss)
                      (apply op result (map First xss)))))
            (error 'Fold-left "all biglists infinite")))
        (error 'Fold-left "not a list of biglists" xss)))
    ))

(define (Fold-right0 op . xss)
  (cond
    ((null? xss)
     (lambda pairs
       (apply Fold-right0 op pairs)))
    (else
      (if ((list-of? List?) xss)
        (let ((cars (map First xss)))
          (if (not (memq eos cars))
            (apply Fold-right
                   op
                   (apply op cars) 
                   (map Rest xss))
            (error 'Fold-right0 "some biglist empty")))
        (error 'Fold-right0 "not a list of finite biglists" xss)))))
;(define (Fold-right0 op . xss)
;  (cond
;    ((null? xss)
;     (lambda (xs)
;       (Fold-right0 op xs)))
;    ((null? (cdr xss))
;     (let ((xs (car xss)))
;       (if (List? xs)
;         (if (Null? xs)
;           (error 'Fold-right0 "biglist empty")
;           (Fold-right op (First xs) (Rest xs)))
;         (error 'Fold-ritht0 "not a finite biglist"))))
;    (else (error 'Fold-right0 "too many arguments"))))

(define (Fold-left0 op . xss)
  (cond
    ((null? xss)
     (lambda pairs
       (apply Fold-left0 op pairs)))
    (else
      (if ((list-of? List?) xss)
        (let ((cars (map First xss)))
          (if (not (memq eos cars))
            (apply Fold-left
                   op
                   (apply op cars) 
                   (map Rest xss))
            (error 'Fold-left0 "some biglist empty")))
        (error 'Fold-left0 "not a list of finite biglists" xss)))))
;(define (Fold-right0 op . xss)
;  (cond
;    ((null? xss)
;     (lambda (xs)
;       (Fold-left0 op xs)))
;    ((null? (cdr xss))
;     (let ((xs (car xss)))
;       (if (List? xs)
;         (if (Null? xs)
;           (error 'Fold-left0 "biglist empty")
;           (Fold-left op (First xs) (Rest xs)))
;         (error 'Fold-left0 "not a finite biglist"))))
;    (else (error 'Fold-left0 "too many arguments"))))

(define (Scan-right op init . xss)
  (cond
    ((null? xss)
     (lambda pairs
       (apply Scan-right op init pairs)))
    (else
      (if ((list-of? BigList?) xss)
        (let ((finite?
                (if (memv #t (map List? xss)) #t #f)))
          (let recur ((n 0) (tails xss))
            (if (memv #t (map Null? tails))
              eos
              (Cons (apply Fold-right op init (map (Take n) xss))
                    (recur (+ n 1) (map Rest tails))
                    finite?))))
        (error 'Scan-right "not a list of biglists" xss)))))

(define (Scan-left op init . xss)
  (cond
    ((null? xss)
     (lambda pairs
       (apply Scan-left op init pairs)))
    (else
      (if ((list-of? BigList?) xss)
        (let ((finite?
                (if (memv #t (map List? xss)) #t #f)))
          (let recur ((n 0) (tails xss))
            (if (memv #t (map Null? tails))
              eos
              (Cons (apply Fold-left op init (map (Take n) xss))
                    (recur (+ n 1) (map Rest tails))
                    finite?))))
        (error 'Scan-left "not a list of biglists" xss)))))

(define Range
  (case-lambda
    ((upto)
     (cond
       ((not upto) ; infinite case
        (Range 0 upto 1))
       ((>= upto 0)
        (Range 0 upto 1))
       (else
         (Range 0 upto -1))))
    ((from upto)
     (cond
       ((not upto) ; infinite case
        (Range from upto 1))
       ((>= upto from)
        (Range from upto 1))
       (else
         (Range from upto -1))))
    ((from upto step)
     (let ((from (if (integer? from)
                   from
                   (error 'Range "not an integer" from)))
           (upto (if (or (not upto) (integer? upto))
                   upto
                   (error 'Range "neither an integer nor #f" upto)))
           (step (if (integer? step)
                   step
                   (error 'Range "not an integer" step))))
       (let recur ((k from))
         (cond
           ((not upto) ; infinite case
            (Cons k (recur (+ k step)) #f))
           ((and (>= upto from) (positive? step))
            (if (>= k upto)
              eos
              (Cons k (recur (+ k step)) #t)))
           ((and (< upto from) (negative? step))
            (if (<= k upto)
              eos
              (Cons k (recur (+ k step)) #t)))
           (else
             (error 'Range "wrong sign of" step))))))
    ))

(define (Repeat x)
  (Cons x (Repeat x) #f))

(define (Repeat-times k x)
  (Take k (Repeat x)))

(define (Iterate-while fn ok? . xs)
  (Take-while ok? (apply Iterate fn xs)))

(define (Iterate-until fn ok? . xs)
  (Take-until ok? (apply Iterate fn xs)))

(define (Iterate-times fn k . xs)
  (Take k (apply Iterate fn xs)))

(define (Iterate fn . xs)
  (cond
    ((null? xs)
     (lambda (x)
       (Iterate fn x)))
    ((null? (cdr xs))
     (let recur ((x (First xs)))
       (Cons x (recur (fn x)) #f)))
    (else 'Iterate "too many arguments")))

(define (Cycle xs)
  (cond
    ((Eager? xs)
     (Cycle (apply List xs)))
    ((List? xs)
     (if (Null? xs)
       eos
       (let recur ((tail xs))
         (if (Null? tail)
           (recur xs)
           (Cons (First tail) (recur (Rest tail)) #f)))))
    (else (error 'Cycle "not a finite biglist" xs))))

(define (Cycle-times k xs)
  (Take k (Cycle xs)))

(define Print
  (case-lambda
    ((k xs)
     (if (BigList? xs)
       (let loop ((n 0) (xs xs))
         (unless (= n k)
           (print (First xs))
           (loop (+ n 1) (Rest xs))))
       (error 'Print "not a biglist" xs)))
    ((xs)
     (if (List? xs)
       (let ((xs xs))
         (Print (Length xs) xs))
       (error 'Print "not a finite biglist" xs)))
    ))

;;; (Collect item-xpr (var xs ok-xpr ...) (var1 xs1 ok-xpr1 ...) ...)
;;; -------------------------------------------------------------
(define-syntax Collect
  (syntax-rules ()
   ((_ item-xpr (var xs ok-xpr ...))
    (cond
      ((Eager? xs)
       (let recur ((seq xs))
         (if (Null? seq)
           '()
           (let ((var (First seq)))
             (if (and ok-xpr ...)
               (Cons item-xpr (recur (Rest seq)))
               (recur (Rest seq)))))))
      ((Lazy? xs)
       (let recur ((seq xs))
         (if (Null? seq)
           eos
           (let ((var (First seq)))
             (if (and ok-xpr ...)
               (Cons item-xpr (recur (Rest seq)) #t)
               (recur (Rest seq)))))))
      (else (error 'Collect "not a biglist" xs))))
    ((_ item-xpr (var xs ok-xpr ...) (var1 xs1 ok-xpr1 ...) ...)
     (let recur ((seq xs))
       (if (Null? seq)
         (cond
           ((Eager? seq) '())
           ((Lazy? seq) eos)
           (else (error 'Collect "not a biglist" seq)))
         (let ((var (First seq)))
           (if (and ok-xpr ...)
             (Append (Collect item-xpr (var1 xs1 ok-xpr1 ...) ...)
                     (recur (Rest seq)))
             (recur (Rest seq)))))))
    ))

(define (Read-forever)
  (Map (lambda (x) (x))
       (Repeat (lambda ()
                 (print* "enter a scheme object (stop with Ctrl-C): ")
                 (let ((obj (read)))
                   (print obj)
                   obj)))))
    
;;; make biglists accessible to pattern matching
;;; ----------------------------------------------
(bind-seq-db BigList?
             #:ref (lambda (xs k) (At k xs))
             #:tail (lambda (xs k) (Drop k xs)))

;(define (integers-from n)
;  (Cons n (integers-from (+ n 1)) #f))
;
;(define integers (integers-from 0))

;;; (biglists sym ..)
;;; ----------------------------
;;; documentation procedure
(define biglists
  (let ((als '(
    (biglists
      procedure:
      (biglists sym ..)
      "documentation procedure")
    (Append
      procedure:
      (Append xs . xss)
      "appends all argument lists, provided all but the last"
      "are finite")
    (Assoc
      procedure:
      (Assoc key)
      (Assoc key xs)
      "returns the biglist, whose First or car is Equal? to key")
    (Assp
      procedure:
      (Assp ok?)
      (Assp ok? xs)
      "returns the biglist, whose First or car passes ok?")
    (Assq
      procedure:
      (Assq key)
      (Assq key xs)
      "returns the biglist, whose First or car is Eq? to key")
    (Assv
      procedure:
      (Assv key)
      (Assv key xs)
      "returns the biglist, whose First or car is Eqv? to key")
    (At
      procedure:
      (At k)
      (At k xs)
      "returns the kth item of xs")
    (BigList?
      procedure:
      (BigList? xpr)
      "type predicate")
    (BigList->list
      procedure:
      (BigList->list xs)
      (BigList->list k xs)
      "transforms a possibly infinite biglist xs into a list")
    (Collect
      macro:
      (Collect item-xpr (var xs ok-xpr ...) (var1 xs1 ok-xpr1 ...) ...)
      "creates a new list by binding var to each element"
      "of the list xs in sequence, and if it passes the checks,"
      "ok-xpr ..., inserts the value of item-xpr into the result list."
      "The qualifieres, (var xs ok-xpr ...), are processed"
      "sequentially from left to right, so that filters of a"
      "qualifier have access to the variables of qualifiers"
      "to its left.")
    (Cons
      macro:
      (Cons x y finite?)
      (Cons x y)
      "returns either a lazy or an eager biglist")
    (Cycle
      procedure:
      (Cycle xs)
      "returns an infinite biglist by appending the finite"
      "biglist xs over and over")
    (Cycle-times
      procedure:
      (Cycle k xs)
      "returns a finite biglist by appending the finite"
      "biglist xs k times")
    (Drop
      procedure:
      (Drop k)
      (Drop k xs)
      "drops the first k items of xs")
    (Drop-while
      procedure:
      (Drop-while ok?)
      (Drop-while ok? xs)
      "returns the xs whith those front items x removed"
      "which pass ok?")
    (Drop-until
      procedure:
      (Drop-until ok?)
      (Drop-until ok? xs)
      "returns the xs whith those front items x removed"
      "which don't pass ok?")
    (Eager?
      procedure:
      (Eager? xpr)
      "is xpr an eager biglist, i.e. a normal list?")
    (Eq?
      procedure:
      (Eq? xs ys)
      "returns #t if both lists have same length"
      "and corresponding items are eq?")
    (Eqp?
      procedure:
      (Eqp? =?)
      (Eqp? =? xs ys)
      "returns #t if both lists have same length"
      "and corresponding items are =?")
    (Equal?
      procedure:
      (Equal? xs ys)
      "returns #t if both lists have same length"
      "and corresponding items are equal?")
    (Eqv?
      procedure:
      (Eqv? xs ys)
      "returns #t if both lists have same length"
      "and corresponding items are eqv?")
    (Every?
      procedure:
      (Every? ok?)
      (Every? ok? xs)
      "returns #t if every item of the finite biglist xs"
      "passes the ok? test")
    (Filter
      procedure:
      (Filter ok?)
      (Filter ok? xs)
      "removes all items from the biglist xs which"
      "do not pass the ok? test")
    (Fold-left
      procedure:
      (Fold-left op init)
      (Fold-left op init . xss)
      "folds the finite biglists xss from the left")
    (Fold-left0
      procedure:
      (Fold-left0 op)
      (Fold-left0 op . xss)
      "folds the finite biglists (map Rest xss) from the left"
      "with init (map First xss)")
    (Fold-right
      procedure:
      (Fold-right op init)
      (Fold-right op init . xss)
      "folds the finite biglists xss from the right")
    (Fold-right0
      procedure:
      (Fold-right0 op)
      (Fold-right0 op . xss)
      "folds the finite biglists (map Rest xss) from the right"
      "with init (map First xss)")
    (For-each
      procedure:
      (For-each fn)
      (For-each fn . xss)
      "applies the procedure fn to each list of items"
      "of xss at each commeon index")
    (First
      procedure:
      (First xs)
      "returns the front item of xs, which might be eos"
      "if xs is empty")
    (Index
      procedure:
      (Index ok?)
      (Index ok? xs)
      "returns the index of the first item of the biglist xs,"
      "which passes the ok? test")
    (Iterate
      procedure:
      (Iterate fn)
      (Iterate fn x)
      "returns an infinite list by iteratively"
      "applying fn to x")
    (Iterate-times
      procedure:
      (Iterate-times fn times)
      (Iterate-times fn times x)
      "returns a finite list of lentgh times by"
      "iteratively applying fn to x")
    (Iterate-until
      procedure:
      (Iterate-until fn ok?)
      (Iterate-until fn ok? x)
      "returns a finite list by iteratively applying"
      "fn to x until ok? returns #t on the result")
    (Iterate-while
      procedure:
      (Iterate-while fn ok?)
      "returns a finite list by iteratively applying"
      "fn to x as long as ok? returns #t on the result")
    (Lazy?
      procedure:
      (Lazy? xpr)
      "is xpr a lazy biglist?")
    (Length
      procedure:
      (Length xs)
      "retuns the length of a finite biglist or #f"
      "of an infinite one")
    (List
      procedure:
      (List . args)
      "creates a lazy finite biglist with items args")
    (List?
      procedure:
      (List? xpr)
      "is xpr a finite biglist?")
    (List-of?
      procedure:
      (List-of? . oks?)
      (List-of? k . oks?)
      "returs a predicate on a biglist, which checks,"
      "if every item (or Take k item) is a finite biglist")
    (Map
      procedure:
      (Map fn)
      (Map fn . xss)
      "maps every list of of items at fixed index of xss"
      "with function fn")
    (Member
      procedure:
      (Member x)
      (Member x xs)
      "returns the first tail af the biglist xs" 
      "whose first item is equal? to x")
    (Memp
      procedure:
      (Memp ok?)
      (Memp ok? xs)
      "returns the first tail af the biglist xs" 
      "which passes the ok? test")
    (Memq
      procedure:
      (Memq x)
      (Memq x xs)
      "returns the first tail af the biglist xs" 
      "whose first item is eq? to x")
    (Memv
      procedure:
      (Memv x)
      (Memv x xs)
      "returns the first tail af the biglist xs" 
      "whose first item is eqv? to x")
    (Merge
      procedure:
      (Merge <? xs ys)
      "merges two finite finite biglists xs and ys,"
      "both lazy or both eager, with respect to <?")
    (Null?
      procedure:
      (Null? xs)
      "is the biglist xs empty?")
    (Print
      procedure:
      (Print k xs)
      (Print xs)
      "print the items of a finite biglist,"
      "or the first k items of an infinite one")
    (Range
      procedure:
      (Range upto)
      (Range from upto)
      (Range from upto step)
      "creates a list of numbers with given limits"
      "from defaults to 0"
      "step defaults to 1"
      "the list is infinite, if utpo is #f")
    (Read-forever
      procedure:
      (Read-forever)
      "creates an infinite biglist of prompted"
      "read procedures")
    (Remove
      procedure:
      (Remove x)
      (Remove x xs)
      "removes all items of the biglist xs, which"
      "are equal? to x")
    (Remp
      procedure:
      (Remp ok?)
      (Remp ok? xs)
      "removes all items of the biglist xs, which"
      "pass the ok? test")
    (Remq
      procedure:
      (Remp x)
      (Remp x xs)
      "removes all items of the biglist xs, which"
      "are eq? to x")
    (Remv
      procedure:
      (Remp x)
      (Remp x xs)
      "removes all items of the biglist xs, which"
      "are eqv? to x")
    (Repeat
      procedure:
      (Repeat x)
      "returns an infinite biglist with all items x")
    (Repeat-times
      procedure:
      (Repeat-times k x)
      "returns a finite biglist of length k with all items x")
    (Rest
      procedure:
      (Rest xs)
      "returns the rest of the list except the front item"
      "which might be xs itself if empty")
    (Reverse
      procedure:
      (Reverse xs)
      (Reversee xs ys)
      "Append the reverse of xs to ys"
      "xs must be finite")
    (Reverse*
      procedure:
      (Reverse* xs)
      "retrurns the list of reverses of"
      "of all finite takes")
    (Scan-left
      procedure:
      (Scan-left op init)
      (Scan-left op init . xss)
      "returns a biglist, whose item at index k"
      "is the left fold of (map (Take k) xss)")
    (Scan-right
      procedure:
      (Scan-right op init)
      (Scan-right op init . xss)
      "returns a biglist, whose item at index k"
      "is the right fold of (map (Take k) xss)")
    (Some?
      procedure:
      (Some? ok?)
      (Some? ok? xs)
      "returns #t if some item of the finite biglist xs"
      "passes the ok? test")
    (Sort
      procedure:
      (Sort <?)
      (Sort <? xs)
      "sorts the finite biglist xs with respect to <?")
    (Sorted?
      procedure:
      (Sorted? <?)
      (Sorted? <? xs)
      "is the biglist xs finite and sorted?")
    (Take
      procedure:
      (Take k)
      (Take k xs)
      "returns the finite biglist of the first"
      "k items of the biglist xs")
    (Take-until
      procedure:
      (Take-until ok?)
      (Take-until ok? xs)
      "returns the finite biglist of the first"
      "items of the biglist xs, which do not pass"
      "the ok? test")
    (Take-while
      procedure:
      (Take-while ok?)
      (Take-while ok? xs)
      "returns the finite biglist of the first"
      "items of the biglist xs, which do pass"
      "the ok? test")
    (Unzip
      procedure:
      (Unzip xs)
      "returns two values, the sublists of biglist xs"
      "of even or uneven index")
    (Zip
      procedure:
      (Zip xs ys)
      "merges the biglists xs and ys by alternatively"
      "Consing (First xs) or (First ys) to the result"
      "biglist. Works for unfinite biglists as well.")
    (eos
      "end-of-sequence indicator")
;    (integers
;      "non-negative integers")
    )))
    (case-lambda
      (()
       (map car als))
      ((sym)
       (let ((pair (assq sym als)))
         (if pair
           (for-each print (cdr pair))
           (error "Not in list"
                  sym
                  (map car als))))))))

) ; module biglists