; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2012-2013, Juergen Lorenz, Moritz Heidkamp
; 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: June 26, 2013
;
(require-library multi-methods)

(module %lazy-lists
  (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?
   Take Drop Ref 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 Every? Some? List)

(import scheme
        (only data-structures o compress list-of?)
        (only chicken
              define-record-type
              define-record-printer
              cut
              when
              void
              add1
              sub1
              fx+ fx= fx>= fx< fx- fx/
              case-lambda
              assert
              nth-value
              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 (Make-lazy len thunk)
  (make-lazy-list len thunk #f))

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

(define Length lazy-list-length)

(define (Length-min . Lsts)
  (let* ((lens (map Length Lsts))
         (finites (compress lens lens)))
    (if (null? finites)
      #f
      (apply min finites))))

(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 Lst out)
  (display "#<List[" out)
  (display (lazy-list-length 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))))))

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

(define (Null? Lst)
  (null? (realize Lst)))

;; 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 (First Lst)
  (car (realize Lst)))

(define Car First)

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

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

(define Cdr Rest)

(define (Ref n Lst)
  (let ((len (lazy-list-length Lst)))
    (assert (or (not len) (fx< n len)))
    (let loop ((n n) (Lst Lst))
      (if (fx= n 0)
        (First Lst)
        (loop (fx- n 1) (Rest Lst))))))

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

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

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

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

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

(define (Take-while ok? Lst)
  (nth-value 0 (Split-with ok? Lst)))

(define (Count-while ok? Lst)
  (nth-value 1 (Split-with ok? Lst)))

(define (Drop-while ok? Lst)
  (nth-value 2 (Split-with ok? Lst)))

(define (Memp ok? Lst)
  (Drop-while (o not ok?) Lst))

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

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

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

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

(define (Eq? Lst1 Lst2)
  (Equ? eq? Lst1 Lst2))

(define (Eqv? Lst1 Lst2)
  (Equ? eqv? Lst1 Lst2))

(define (Equal? Lst1 Lst2)
  (Equ? equal? Lst1 Lst2))

(define (Assp ok? al)
  (let (
    (Lst (Drop-while (lambda (pair) (not (ok? (car pair)))) al))
    )
    (if (Null? Lst) #f (First Lst))))

(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 . Lsts)
  (if (null? Lsts)
    Nil
    (let ((len (apply Length-min Lsts)))
      (let loop ((Lsts Lsts))
        (Lazy len
          (if (Null? (car Lsts))
            '()
            (cons (apply proc (map First Lsts))
                  (loop (map rest Lsts)))))))))

(define (For-each proc . Lsts)
  (if (null? Lsts)
    (void)
    ;; at least one finite
    (let ((len (apply Length-min Lsts)))
      (do ((Lsts Lsts (Rest Lsts)) (k 0 (fx+ k 1)))
        ((fx= k len))
        (apply proc (map First Lsts))))))

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

(define (Zip Lst1 Lst2)
  (if (Null? Lst1)
    Lst2
    (if (and (lazy-list-length Lst1) (lazy-list-length Lst2))
      ;; both finite, compute new length with Cons
      (Cons (First Lst1) (Zip Lst2 (Rest Lst1)))
      ;; new length infinite
      (Lazy #f 
        (cons (First Lst1) (Zip Lst2 (Rest Lst1)))))))
   
(define (input->List port read)
  (let loop ()
    ;(Lazy #f
      (let ((datum (read port)))
        (if (eof-object? datum)
            Nil
            ;'()
            (Cons datum (loop))))));)

(define Repeat
  (case-lambda
    ((x) (Lazy #f (cons x (Repeat x))))
    ((n x) (Take n (Repeat x)))))

(define Repeatedly
  (case-lambda
    ((thunk) (Lazy #f (cons (thunk) (Repeatedly thunk))))
    ((n thunk) (Take n (Repeatedly thunk)))))

(define Iterate
  (case-lambda
    ((f x) (Lazy #f (cons x (Iterate f (f x)))))
    ((n f x) (Take n (Iterate f x)))))

(define Cycle
  (case-lambda
    ((Lst)
     (if (Null? Lst)
       Nil
       (let loop ((tail Lst))
         (Lazy #f
           (if (Null? tail)
             (loop Lst)
             (cons (First tail)
                   (loop (rest tail))))))))
    ((n Lst) (Take n (Cycle Lst)))))

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

(define (Append2 Lst1 Lst2)
  (if (not (lazy-list-length Lst1))
    Lst1
    (let loop ((Lst Lst1))
      (Lazy (if (lazy-list-length Lst2)
              (+ (lazy-list-length Lst1)
                 (lazy-list-length Lst2))
              #f)
        (if (Null? Lst)
          Lst2
          (cons (First Lst) (loop (rest Lst))))))))

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

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

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

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

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

(define (Sorted? <? Lst)
  (let loop ((Lst Lst))
    (cond
      ((Null? Lst) #t)
      ((Null? (Cdr Lst)) #t)
      ((<? (Car Lst) (Car (Cdr Lst)))
       (loop (Cdr Lst)))
      (else #f))))

(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 Lst)
  (let ((vec (make-vector (lazy-list-length Lst) #f)))
    (let loop ((k 0) (Lst Lst))
      (cond
        ((Null? Lst)
         vec)
        (else
          (vector-set! vec k (First Lst))
          (loop (+ k 1) (rest Lst)))))))

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

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

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

(define (Fold-left op base . Lsts)
  ;; at least one of finite Length
  (let loop ((base base)
             (Lsts Lsts)
             (len (apply Length-min Lsts)))
    (if (zero? len)
      base
      (loop (apply op base (map First Lsts))
            (map Rest Lsts)
            (fx- len 1)))))

(define (Fold-right op base . Lsts)
  ;; at least one of finite Length
  (let loop ((Lsts Lsts)
             (len (apply Length-min Lsts)))
    (if (zero? 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 . Lsts)
  (letrec (
    (fold
      (Cons base
        (apply Map op
                   (Lazy (apply Length-min Lsts) fold)
                   Lsts)))
    )
    (Rest fold)))

(define (Fold-right* op base . Lsts) ; changes order of List items
  (letrec (
    (fold
      (Cons base
        (apply Map op
               (append Lsts
                       (list
                         (Lazy (apply Length-min Lsts) fold))))))
    )
    (Rest fold)))

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

(define (Some? ok? 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)))

(define (List-infinite? xpr)
  (and (List? xpr) (if (Length xpr) #f #t)))

(define (Lists-one-finite? . Lsts)
  (and ((list-of? List?) Lsts)
       (not (null? Lsts))
       (let ((len (apply Length-min Lsts)))
         (if len #t #f))))

;; only finite Lists
(define (Realize Lst)
  (let ((len (lazy-list-length Lst)))
    (when len
      (Ref (- len 1) Lst)
      Lst)))
  
) ; module %lazy-lists

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

(import scheme
        (only methods method query-checker no-checker
              method-check-args-and-call effects-checked?)
        (only chicken fixnum? fx>= fx<= fx- fx+ fx= fx< fx* fx/ signum)
        (only data-structures o list-of? conjoin sort)
        (prefix %lazy-lists %))
;(import-for-syntax (only methods method query-checker no-checker))

;;; helpers
(define (any? xpr) #t)
(define (%List-index? xpr)
  (and (fixnum? xpr) (fx>= xpr 0)))
;(define (all? ok?)
;  (lambda (lst)
;    (let loop ((lst lst))
;      (cond
;        ((null? lst) #t)
;        ((ok? (car lst))
;         (loop (cdr lst)))
;        (else #f)))))

(define-syntax Lazy
  (syntax-rules ()
    ((_ len xpr . xprs)
     (%Lazy len xpr . xprs))))

(define Make-lazy
  (method ('Make-lazy
           %Make-lazy
           (query-checker
             (lambda (len thunk)
               (lambda (result)
                 (and (%List? result)
                      (eqv? (%Length result) len))))
             '(List-of-given-length? result)))
          ('1lazy-length? (lambda (xpr)
                            (or (not xpr)
                                (and (fixnum? xpr)
                                     (fx>= xpr 0)))))
          ('2thunk? procedure?)))

(define Cons
  (method ('Cons
           %Cons
           (query-checker
             (lambda (var Lst)
               (lambda (result)
                 (if (%Length Lst)
                   (fx= (%Length result)
                        (fx+ (%Length Lst) 1))
                   #f)))
             '(= (Length result) (+ (Length Lst) 1))))
          ('1any? any?)
          ('2List? %List?)))


(define Length
  (method ('Length
           %Length
           (query-checker
             (lambda (Lst)
               (lambda (result)
                 (or (not result)
                     (and (fixnum? result)
                          (fx>= result 0)))))
             '(not-or-not-negative-fixnum? result)))
          ('1List? %List?)))

(define Length-min
  (method #t ; variadic
          ('Length-min
           %Length-min
           (query-checker
             (lambda Lsts
               (lambda (result)
                 (or (not result)
                     (%List-index? result))))
                 '(or (not result)
                     (List-index? result))))
          ('1Lists? (list-of? %List?))))

(define Nil
  %Nil)

(define Range
  (method #t ; variadic
          ('Range
           %Range
           (query-checker
             (lambda (arg . args)
               (lambda (result)
                 (let (
                   (from (cond
                           ((null? args) 0)
                           ((null? (cdr args)) arg)))
                   (upto (cond
                           ((null? args) arg)
                           ((null? (cdr args)) (car args)))) 
                   (step (cond
                           ((null? args) (signum arg))
                           ((null? (cdr args)) (signum (fx- (car args) arg)))
                           (else (fx* (abs (cadr args))
                                      (signum (fx- (car args) arg))))))
                   )
                   (and (%List-finite? result)
                        (fx= (%Length result)
                             (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step))))))
             '(and (List-finite? result)
                  (= (Length result)
                     (quotient (+ (- step 1) (abs (- upto from))) step)))))
          ('1integer? integer?)
          ('2integers? (list-of? integer?))))

(define Cardinals
  (method ('Cardinals
           %Cardinals
           (query-checker
             (lambda ()
               (lambda (result)
                 (and (%List? result)
                      (not (%Length result)))))
             '(List-infinite? result)))))

(define Primes
  (method ('Primes
           %Primes
           (query-checker
             (lambda ()
               (lambda (result)
                 (and (%List? result)
                      (not (%Length result)))))
             '(List-infinite? result)))))

;; helper
(define boolean-checker
  (query-checker
    (lambda (xpr)
      (lambda (result)
        (boolean? result)))
    '(boolean? result)))

(define Realized?
  (method ('Realized? %Realized? boolean-checker)
          ('1List? %List?)))

(define Null?
  (method ('Null? %Null? boolean-checker)
          ('1List? %List?)))

(define List?
  (method ('List? %List? boolean-checker)
          ('1any? any?)))

(define List-not-null?
  (method ('List-not-null?  %List-not-null? boolean-checker)
          ('1any? any?)))

(define List-finite?
  (method ('List-finite?  %List-finite? boolean-checker)
          ('1any? any?)))

(define List-infinite?
  (method ('List-finite?  %List-infinite? boolean-checker)
          ('1any? any?)))

(define Lists-one-finite?
  (method #t ; variadic
          ('Lists-one-finite?
           %Lists-one-finite?
           (query-checker
             (lambda Lsts
               (lambda (result)
                 (boolean? result)))
             '(boolean? result)))
          ('1Lists? (list-of? %List?))))

(define First
  (method ('First
           %First
           (query-checker
             (lambda (Lst)
               (lambda (result)
                 (any? result)))
             '(any? result)))
          ('1List-not-null? %List-not-null?)))

(define Car
  (method ('Car
           %Car
           (query-checker
             (lambda (Lst)
               (lambda (result)
                 (any? result)))
             '(any? result)))
          ('1List-not-null? %List-not-null?)))

;; helper
(define List-checker
  (query-checker
    (lambda (Lst)
      (lambda (result)
        (%List? result)))
    '(List? result)))

(define Rest
  (method ('Rest %Rest List-checker)
          ('1List-not-null? %List-not-null?)))

(define Cdr
  (method ('Cdr %Cdr List-checker)
          ('1List-not-null? %List-not-null?)))

(define Realize
  (method ('Realize %Realize List-checker)
          ('1List-finite? %List-finite?)))

(define Ref
  (method ('Ref
           %Ref
           (query-checker
             (lambda (n Lst)
               (lambda (result)
                 (any? result)))
             '(any result)))
          ('1List-valid-index? %List-index?)
          ('2List? %List?)))

(define list->List
  (method ('list->List
           %list->List
           (query-checker
             (lambda (lst)
               (lambda (result)
                 (and (%List-finite? result)
                      (fx= (length lst) (%Length result)))))
             '(and (List-finite? result)
                   (= (length arg) (Length result)))))
          ('1list? list?)))

(define vector->List
  (method ('vector->List
           %vector->List
           (query-checker
             (lambda (vec)
               (lambda (result)
                 (and (%List-finite? result)
                      (fx= (vector-length vec) (%Length result)))))
             '(and (List-finite? result)
                   (= (vector-length arg) (Length result)))))
          ('1vector? vector?)))

(define List->list
  (method ('List->list
           %List->list
           (query-checker
             (lambda (Lst)
               (lambda (result)
                 (and (list? result)
                      (fx= (length result) (%Length Lst)))))
             '(and (list? result) (= (length result) (Length arg)))))
          ('1List-finite? %List-finite?)))

(define List->vector
  (method ('List->vector
           %List->vector
           (query-checker
             (lambda (Lst)
               (lambda (result)
                 (and (vector? result)
                      (fx= (vector-length result)
                           (%Length Lst)))))
             '(and (vector? result)
                   (= (vector-length result) (Length arg)))))
          ('1List-finite? %List-finite?)))

(define List
  (method #t ; variadic
          ('List
           %List
           (query-checker
             (lambda args
               (lambda (result)
                 (and (%List-finite? result)
                      (fx= (length args) (%Length result)))))
             '(and (List-finite? result) (= (length args) (Length result)))))
          ('1list? list?)))

(define Take
  (method ('Take
           %Take
           (query-checker
             (lambda (n Lst)
               (lambda (result)
                 (and (%List? result) (%Length result)
                      (if (%Length Lst)
                        (fx= (%Length result) (min n (%Length Lst)))
                        (fx= (%Length result) n)))))
             '(and (List? result) (Length result)
                   (if (Length Lst)
                     (= (Length result) (min n (Length Lst)))
                     (= (Length result) n)))))
          ('1List-index? %List-index?)
          ('2List? %List?)))

(define Drop
  (method ('Drop
           %Drop
           (query-checker
             (lambda (n Lst)
               (lambda (result)
                 (and (%List? result)
                      (if (%Length Lst)
                        (fx= (%Length result) (max 0 (- (%Length Lst) n)))
                        (not (%Length result))))))
             '(and (List? result)
                   (if (Length Lst)
                     (= (Length result) (max 0 (- (Length Lst) n)))
                     (not (Length result))))))
          ('1List-index? %List-index?)
          ('2List? %List?)))

(define Split-at
  (method ('Split-at
           %Split-at
           (query-checker
             (lambda (n Lst)
               (lambda (head tail)
                 (and (%List? head) (%Length head) (%List tail)
                      (if (%Length Lst)
                        (and (fx= (%Length head) (min n (%Length Lst)))
                             (fx= (%Length tail) (max 0 (fx- (%Length Lst) n)))
                             (%Equal? Lst (%Append head tail)))
                        (and (fx= (%Length head) n)
                             (not (%Length tail)))))))
             '(and (List? head) (Length head) (List tail)
                   (if (Length Lst)
                     (and (= (Length head) (min n (Length Lst)))
                          (= (Length tail) (max 0 (- (Length Lst) n)))
                          (Equal? Lst (Append head tail)))
                     (and (= (Length head) n)
                          (not (Length tail)))))))
          ('1List-index? %List-index?)
          ('2List? %List?)))

;; helper
(define Sublist-finite-checker
  (query-checker
    (lambda (any Lst)
      (lambda (result)
        (and (%List? result)
             (fx<= (%Length result) (%Length Lst)))))
    '(and (List? result)
          (<= (Length result) (Length Lst)))))

(define Take-while
  (method ('Take-while %Take-while Sublist-finite-checker)
          ('1unary-predicate? procedure?)
          ('2List-finite? %List-finite?)))

(define Drop-while
  (method ('Drop-while %Drop-while Sublist-finite-checker)
          ('1unary-predicate? procedure?)
          ('2List-finite? %List-finite?)))

(define Split-with
  (method ('Split-with
           %Split-with
           (query-checker
             (lambda (ok? Lst)
               (lambda (head index tail)
                 (and (%List-finite? head)
                      (fx<= (%Length head) (%Length Lst))
                      (%List-index? index)
                      (%List-finite? tail)
                      (fx<= (%Length tail) (%Length Lst)))))
             '(and (List-finite? head)
                   (<= (Length head) (Length Lst))
                   (List-index? index)
                   (List-finite? tail)
                   (<= (Length tail) (Length Lst)))))
          ('1unary-predicate? procedure?)
          ('2List-finite? %List-finite?)))

(define Memp
  (method ('Memp %Memp Sublist-finite-checker)
          ('1unary-predicate? procedure?)
          ('2List-finite? %List-finite?)))

(define Memq
  (method ('Memq %Memq Sublist-finite-checker)
          ('1any? any?)
          ('2List-finite? %List-finite?)))

(define Memv
  (method ('Memv %Memv Sublist-finite-checker)
          ('1any? any?)
          ('2List-finite? %List-finite?)))

(define Member
  (method ('Member %Member Sublist-finite-checker)
          ('1any? any?)
          ('2List-finite? %List-finite?)))

(define Count-while
  (method ('Count-while
           %Count-while
           (query-checker
             (lambda (ok? Lst)
               (lambda (result)
                 (%List-index? result)))
             '(List-index? result)))
          ('1unary-predicate? procedure?)
          ('2List-finite? %List-finite?)))

(define Equ?
  (method ('Equ?
           %Equ?
           (query-checker
             (lambda (=? Lst1 Lst2)
               (lambda (result)
                 (boolean? result)))
             '(boolean? result)))
          ('1binary-predicate? procedure?)
          ('2List? %List?)
          ('3List? %List?)))

;; helper
(define two-args-boolean-checker
  (query-checker
    (lambda (Lst1 Lst2)
      (lambda (result)
        (boolean? result)))
    '(boolean? result)))

(define Eq?
  (method ('Eq? %Eq? two-args-boolean-checker)
          ('1List? %List?)
          ('2List? %List?)))

(define Eqv?
  (method ('Eqv? %Eq? two-args-boolean-checker)
          ('1List? %List?)
          ('2List? %List?)))

(define Equal?
  (method ('Equal? %Equal? two-args-boolean-checker)
          ('1List? %List?)
          ('2List? %List?)))

(define Sorted?
  (method ('Sorted? %Sorted? two-args-boolean-checker)
          ('1binary-comparison? procedure?)
          ('2List-finite? %List-finite?)))

(define Every?
  (method ('Every? %Every? two-args-boolean-checker)
          ('1unary-predicate? procedure?)
          ('2List-finite? %List-finite?)))

(define Some?
  (method ('Some? %Some? two-args-boolean-checker)
          ('1unary-predicate? procedure?)
          ('2List-finite? %List-finite?)))

;; helper
(define List-of-pair-checker
  (query-checker
    (lambda (var aLst)
      (lambda (result)
        (or (not result) (pair? result))))
    '(or (not result) (pair? result))))

(define Assp
  (method ('Assp %Assp List-of-pair-checker)
          ('1unary-predicate? procedure?)
          ('2List-of-pair? %List?)))

(define Assq
  (method ('Assq %Assq List-of-pair-checker)
          ('1key? any?)
          ('2List-of-pair? %List?)))

(define Assv
  (method ('Assv %Assv List-of-pair-checker)
          ('1key? any?)
          ('2List-of-pair? %List?)))

(define Assoc
  (method ('Assoc %Assoc List-of-pair-checker)
          ('1key? any?)
          ('2List-of-pair? %List?)))

(define Map
  (method #t ; variadic
          ('Map
           %Map
           (query-checker
             (lambda (proc . Lsts)
               (lambda (result)
                 (and (%List? result)
                      (eqv? (%Length result) (apply %Length-min Lsts)))))
             '(and (List? result)
                   (eqv? (Length result) (apply Length-min Lsts)))))
          ('1procedure-of-matching-argument-number? procedure?)
          ('2Lists? (conjoin (o not null?) (list-of? %List?)))))

(define For-each
  (method #t ; variadic
          ('For-each
           %For-each
           (no-checker "lazy for-each"))
          ('1procedure-of-matching-argument-number? procedure?)
          ('2Lists-one-finite? %Lists-one-finite?)))

(define Filter
  (method ('Filter
           %Filter
           (query-checker
             (lambda (ok? Lst)
               (lambda (result)
                 (and (%List? result)
                      (or (not (%Length Lst))
                          (fx<= (%Length result) (%Length Lst))))))
             '(and (List? result)
                   (or (not (Length Lst))
                       (<= (Length result) (Length Lst))))))
          ('1unary-predicate? procedure?)
          ('2List? %List?)))

(define input->List
  (method ('input->List
           %input->List
           (query-checker
             (lambda (port read-proc)
               (lambda (result)
                 (%List-finite? result)))
             '(List-finite? result)))
          ('1input-port? input-port?)
          ('2read-procedure? procedure?)))

;; helper
(define List-infinite-checker
  (query-checker
    (lambda (any)
      (lambda (result)
        (and (%List result) (not (%Length result)))))
    '(and (List result) (not (Length result)))))

(define List-of-given-length-checker
  (query-checker
    (lambda args
      (lambda (result)
        (if (null? (cdr args))
          (%List-infinite? result)
          (and (%List? result)
               (fx= (%Length result) (car args))))))
    '(if (null? (cdr args))
       (List-infinite? result)
       (and (List? result)
            (= (Length result) (car args))))))

(define (any-or-index+any? args)
  (and (list? args)
       (<= 1 (length args) 2)
       (if (null? (cdr args))
         (any? (car args))
         (and (%List-index? (car args))
              (any? (cadr args))))))

(define Repeat
  (method #t ; variadic
          ('Repeat
           %Repeat
           List-of-given-length-checker)
          ('1any-or-index+any? any-or-index+any?)))

(define Repeatedly
  (method #t ; variadic
          ('Repeatedly %Repeatedly List-of-given-length-checker)
          ('1thunk-or-index+thunk?
           (lambda (args)
             (and (list? args)
                  (<= 1 (length args) 2)
                  (if (null? (cdr args))
                    (procedure? (car args))
                    (and (%List-index? (car args))
                         (procedure? (cadr args)))))))))

(define Iterate
  (method #t ;variadic
          ('Iterate %Iterate List-of-given-length-checker)
          ('1proc+any-or-index+proc+any?
           (lambda (args)
             (and (list? args)
                  (<= 2 (length args) 3)
                  (if (null? (cddr args))
                    (procedure? (car args))
                    (and (%List-index? (car args))
                         (procedure? (cadr args)))))))))

(define Cycle
  (method #t ; variadic
          ('Cycle %Cycle List-of-given-length-checker)
          ('1List-finite-or-index+List-finite?
           (lambda (args)
             (and (list? args)
                  (<= 1 (length args) 2)
                  (if (null? (cdr args))
                    (%List-finite? (car args))
                    (and (%List-index? (car args))
                         (%List-finite? (cadr args)))))))))

(define Append
  (method #t ; variadic
          ('Append
           %Append
           (query-checker
             (lambda Lsts
              (lambda (result)
                (and (%List? result)
                     (or (not (%Length result))
                         (fx= (%Length result)
                              (apply + (map %Length Lsts)))))))
            '(and (List? result)
                  (or (not (Length result))
                      (= (Length result) (apply + (map Length Lsts)))))))
          ('1Lists? (list-of? %List?))))

(define Reverse
  (method ('Reverse
           %Reverse
           (query-checker
             (lambda (Lst)
               (lambda (result)
                 (and (%List-finite? result)
                      (fx= (%Length result) (%Length Lst)))))
             '(and (List-finite? result)
                   (= (Length result) (Length arg)))))
          ('1List-finite? %List-finite?)))

(define Reverse*
  (method ('Reverse*
           %Reverse*
           (query-checker
             (lambda (Lst)
               (lambda (result)
                 (and (%List? result)
                      (eqv? (%Length result) (%Length Lst)))))
             '(and (List? result)
                   (eqv? (Length result) (Length Lst)))))
          ('1List? %List?)))

(define Merge
  (method ('Merge
           %Merge
           (query-checker
             (lambda (<? Lst1 Lst2)
               (lambda (result)
                 (and (%List-finite? result)
                      (fx= (%Length result)
                           (fx+ (%Length Lst1) (%Length Lst2))))))
             '(and (List-finite? result)
                   (= (Length result)
                      (+ (Length arg1) (Length arg2))))))
          ('1binary-comparison? procedure?)
          ('2List-finite-sorted? (conjoin %List-finite? %Sorted?))
          ('3List-finite-sorted? (conjoin %List-finite? %Sorted?))))

(define Sort
  (method ('Sort
           %Sort
           (query-checker
             (lambda (<? Lst)
               (lambda (result)
                 (and (%List? result)
                      (fx= (%Length result) (%Length Lst)))))
             '(and (List? result)
                   (= (Length result) (Length Lst)))))
          ('1binary-comparison? procedure?)
          ('2List-finite? %List-finite?)))

(define Sieve
  (method ('Sieve
           %Sieve
           (query-checker
             (lambda (=? Lst)
               (lambda (result)
                 (and (%List? result)
                      (if (%Length Lst)
                        (fx<= (%Length result) (%Length Lst))
                        (not (%Length result))))))
             '(and (List? result)
                   "not two items =?"
                   (if (Length Lst)
                     (<= (Length result) (Length Lst))
                     (not (Length result))))))
          ('1binary-predicate? procedure?)
          ('2List? %List?)))

(define Fold-left
  (method #t ;variadic
          ('Fold-left
           %Fold-left
           (no-checker "lazy version of fold-left"))
          ('1operator-of-matching-length? procedure?)
          ('2any? any?)
          ('3Lists-one-finite? %Lists-one-finite?)))

(define Fold-right
  (method #t ;variadic
          ('Fold-right
           %Fold-right
           (no-checker "lazy version of fold-right"))
          ('1operator-of-matching-length? procedure?)
          ('2any? any?)
          ('3Lists-one-finite? %Lists-one-finite?)))

;; helpers
(define Fold*-checker
  (query-checker
    (lambda (op base . Lsts)
      (lambda (result)
        (and (%List? result)
             (if (null? Lsts)
               (not (%Length result))
               (eqv? (%Length result) (%Length (car Lsts)))))))
    '(and (List? result)
          (if (null? Lsts)
            (not (Length result))
            (eqv? (Length result) (Length (car Lsts)))))))

(define Fold-left*
  (method #t ;variadic
          ('Fold-left* %Fold-left* Fold*-checker)
          ('1operator-of-matching-length? procedure?)
          ('2any? any?)
          ('3Lists?not-null? (list-of? %List?) (o not null?))))

(define Fold-right*
  (method #t ;variadic
          ('Fold-right* %Fold-right* Fold*-checker)
          ('1operator-of-matching-length? procedure?)
          ('2any? any?)
          ('3Lists?not-null? (list-of? %List?) (o not null?))))

(define Zip
  (method ('Zip
           %Zip
           (query-checker
             (lambda (Lst1 Lst2)
               (lambda (result)
                 (and (%List? result)
                      (eqv? (%Length result)
                            (if (and (%Length Lst1) (%Length Lst2))
                              (fx+ (%Length Lst1) (%Length Lst2))
                              #f)))))
             '(and (List? result)
                   (eqv? (Length result)
                         (if (and (Length Lst1) (Length Lst2))
                           (fx+ (Length Lst1) (Length Lst2))
                           #f)))))
          ('1List? %List?)
          ('2List? %List?)))

(define (lazy-lists)
  (sort
    '(Lazy List Make-lazy
       List-not-null? List-finite? List-infinite?
       Equ? Equal? Eq? Eqv?
       List? Null? Realized? Realize
       Every? Some?
       Car Cdr Nil Cons 
       List->list list->List input->List
       First Rest Length Append Reverse
       Reverse*
       Take Drop Ref Take-while Drop-while
       Memp Member Memq Memv Count-while
       Assp Assoc Assq Assv
       Map Filter Sieve For-each
       Iterate Repeat Repeatedly
       Cardinals Primes Cycle Range
       Merge Sort Sorted? Split-at Split-with
       vector->List List->vector
       Fold-right Fold-left Fold-right* Fold-left* Zip
       )
    (lambda (x y)
      (string<? (symbol->string x) (symbol->string y)))))

) ; module lazy-lists