#|[
Author: Juergen Lorenz
ju (at) jugilo (dot) de

Copyright (c) 2014, 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.
]|#

(require-library datatype)

(define-interface LISTS
  (ilists ilist? ilist list->ilist ilist->list
   ilist-apply ilist-null ilist-null? ilist-cons ilist-first ilist-rest ilist-reverse
   ilist-length ilist-item ilist-map ilist-for-each ilist-append ilist-mappend
   ilist-from-upto ilist-split-at ilist-split-with ilist-equal? ilist-member
   ilist-memp ilist-remp ilist-remove ilist-remove-dups ilist-assp ilist-assoc
   ilist-filter ilist-fold-left ilist-fold-right ilist-merge ilist-merge-sort
   ilist-insertion-sort ilist-sorted? ilist-insert-sorted ilist-drop
   ilist-drop-while ilist-take ilist-take-while ilist-repeat ilist-iterate
   ilist-iterate-while ilist-iterate-until ilist-zip ilist-unzip ilist-interpose
   ilist-every? ilist-some ilist-not-every? ilist-not-any? ilist-in? ilist-bind))

(define-interface SETS
   (sets set? set ilist->set set->ilist set-in?  set-cardinality
    set-filter set-null? set-difference set-add set-remove
    set= set>= set<= set-union set-intersection))

(functor (list-functor (M (item? equ?))) LISTS

(import scheme
        (only chicken error define-record-printer
              unless receive case-lambda)
        (only data-structures list-of? o)
        (only extras sprintf)
        datatype
        M)

(import-for-syntax (only chicken receive))

(define-datatype ilist ilist?
  (ilist-null)
  (ilist-cons
    (first item?)
    (rest ilist?)))

(define-record-printer (ilist ilst out)
  (let ((str (sprintf "~s" (ilist->list ilst))))
    (string-set! str (- (string-length str) 1) #\])
    (string-set! str 0 #\[)
    (display str out)))

;(define-reader-ctor 'typed ilist)

(define (ilist-null? xpr)
  (and (ilist? xpr)
       (cases ilist xpr
         (ilist-null () #t)
         (ilist-cons (first rest) #f))))

(define (ilist-first lst)
  (cases ilist lst
    (ilist-null () (error 'ilist-first "list empty" lst))
    (ilist-cons (first rest) first)))

(define (ilist-rest lst)
  (cases ilist lst
    (ilist-null () (error 'ilist-rest "list empty" lst))
    (ilist-cons (first rest) rest)))

(define-syntax ilist-bind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form))
            (ilst (caddr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        (let ((ilst ilst))
                    ;; not available at compile time
                    ;(if (ilist? ilst)
                    ;  ilst
                    ;  (error 'ilist-bind
                    ;         "not a typed list"
                    ;         ilst))))
          (if (list? pat)
            `(if (= ,(length pat) (ilist-length ,ilst))
               (ilist-apply (lambda ,pat ,xpr ,@xprs) ,ilst)
               (error 'ilist-bind "match error" ',pat ,ilst))
            ;; pseudolist: separate list part
            (receive (head tail)
              (let loop ((pat pat) (lst '()))
                (if (pair? pat)
                  (loop (cdr pat) (cons (car pat) lst))
                  (values (reverse lst) pat)))
              `(if (<= ,(length head) (ilist-length ,ilst))
                 (receive (hd tl) (ilist-split-at ,(length head) ,ilst)
                   (let ((,tail tl))
                     (ilist-apply (lambda ,head ,xpr ,@xprs) hd)))
                 (error 'ilist-bind "match error" ',pat ,ilst)))))))))

(define (ilist-reverse . lsts)
  (cond
    ((null? lsts)
     (ilist-null))
    ((null? (cdr lsts))
     (let loop ((ls (car lsts)) (result (ilist-null)))
       (cases ilist ls
         (ilist-null () result)
         (ilist-cons (first rest)
                    (loop rest (ilist-cons first result))))))
    (else
      (let loop (
        (lsts lsts)
        (results ;(make-list (length lsts) (ilist-null)))
                 (let recur ((n (length lsts))
                             (result '()))
                   (if (zero? n)
                     result
                     (recur (- n 1) (cons (ilist-null) result)))))
        )
        (cond
          (((list-of? ilist-null?) lsts)
           (apply values results))
          (((list-of? (o not ilist-null?)) lsts)
           (loop (map ilist-rest lsts)
                 (map (lambda (l ll) (ilist-cons l ll))
                      (map ilist-first lsts)
                      results)))
          (else (error 'ilist-reverse "lists not of equal length")))))))

(define (ilist . args)
  (let loop ((args args) (result (ilist-null)))
    (if (null? args)
      (ilist-reverse result)
      (loop (cdr args) (ilist-cons (car args) result)))))

(define (ilist-repeat n x)
  (let loop ((k 0) (result (ilist-null)))
    (if (= k n)
      result
      (loop (+ k 1) (ilist-cons x result)))))

(define (ilist-iterate n fn x)
  (let loop ((k 0) (val x) (result (ilist-null)))
    (if (= k n)
      (ilist-reverse result)
      (loop (+ k 1) (fn val) (ilist-cons val result)))))

(define (ilist-iterate-while ok? fn x)
  (let loop ((val x) (result (ilist-null)))
    (if (ok? val)
      (loop (fn val) (ilist-cons val result))
      (ilist-reverse result))))

(define (ilist-iterate-until ok? fn x)
  (let loop ((val x) (result (ilist-null)))
    (if (ok? val)
      (ilist-reverse result)
      (loop (fn val) (ilist-cons val result)))))

(define (ilist->list lst)
  (let loop ((ls lst) (result '()))
    (cases ilist ls
      (ilist-null () (reverse result))
      (ilist-cons (first rest)
       (loop rest (cons first result))))))

;(define (ilist-apply fn . args)
;  (let ((len (length args)))
;    (apply fn
;      (let loop ((k 0) (result '()))
;        (cond
;          ((= k len) (reverse result))
;          ((= k (- len 1))
;           (let ((tail (list-ref args k)))
;             (if (ilist? tail)
;               (loop (+ k 1)
;                     (append
;                       (reverse
;                         (ilist->list tail))
;                       result))
;               (error 'ilist-apply
;                      (string-append
;                        "not an "
;                        (symbol->string
;                          'ilist))
;                      tail))))
;          (else
;            (let ((item (list-ref args k)))
;              (if (item? item)
;                (loop (+ k 1)
;                      (cons item result))
;                (error 'ilist-apply
;                       "wrong item-type"
;                       `(,item? ,item))))))))))
(define (ilist-apply fn . args)
  (let ((args (reverse args)))
    (cond
      ((null? args)
       (error 'ilist-apply "no argument supplied"))
      ((ilist? (car args))
       (let ((head (reverse (ilist->list (car args))))
             (tail (cdr args)))
         (apply fn (reverse (append head tail)))))
      (else
        (error 'ilist-apply "not an ilist" (car args))))))


(define (list->ilist lst)
  (apply ilist lst))

(define (ilist-length lst)
  (let loop ((ls lst) (k 0))
    (cases ilist ls
      (ilist-null () k)
      (ilist-cons (first rest)
        (loop rest (+ k 1))))))

(define (ilist-item k lst)
  (let loop ((ls lst) (n 0))
    (cases ilist ls
      (ilist-null () (error 'ilist-item "range error"))
      (ilist-cons (first rest)
        (if (= n k)
          first
          (loop rest (+ n 1)))))))

(define (ilist-from-upto from upto lst)
  (let loop ((ls lst) (k 0) (result (ilist-null)))
    (cases ilist ls
      (ilist-null () (ilist-reverse result))
      (ilist-cons (first rest)
        (cond
          ((= k upto)
           (ilist-reverse result))
          ((< k from)
           (loop rest (+ k 1) result))
          (else
            (loop rest (+ k 1) (ilist-cons first result))))))))

(define (ilist-split-at k lst)
  (let loop ((ls lst) (n 0) (head (ilist-null)))
    (cases ilist ls
      (ilist-null () (values (ilist-reverse head) ls))
      (ilist-cons (first rest)
        (if (= n k)
         (values (ilist-reverse head) ls)
         (loop rest (+ n 1) (ilist-cons first head)))))))

(define (ilist-split-with ok? lst)
  (let loop ((ls lst) (head (ilist-null)))
    (cases ilist ls
      (ilist-null () (values (ilist-reverse head) ls))
      (ilist-cons (first rest)
        (if (ok? first)
          (values (ilist-reverse head) ls)
          (loop rest (ilist-cons first head)))))))

(define (ilist-take k lst)
  (call-with-values
    (lambda () (ilist-split-at k lst))
    (lambda (head tail) head)))

(define (ilist-take-while ok? lst)
  (call-with-values
    (lambda () (ilist-split-with (o not ok?) lst))
    (lambda (head tail) head)))

(define (ilist-drop k lst)
  (call-with-values
    (lambda () (ilist-split-at k lst))
    (lambda (head tail) tail)))

(define (ilist-drop-while ok? lst)
  (call-with-values
    (lambda () (ilist-split-with (o not ok?) lst))
    (lambda (head tail) tail)))

(define (ilist-append . lsts)
  (cond
    ((null? lsts)
     (ilist-null))
    ((null? (cdr lsts))
     (car lsts))
    ((null? (cddr lsts))
     (let loop ((ls0 (ilist-reverse (car lsts)))
                (result (cadr lsts)))
       (cases ilist ls0
         (ilist-null () result)
         (ilist-cons (first rest)
                 (loop rest (ilist-cons first result))))))
    (else
      (ilist-append (car lsts)
                (apply ilist-append (cdr lsts))))))

;(define (ilist-mappend fn . lsts)
;  (apply ilist-append
;         (apply map fn
;                (map ilist->list lsts))))

(define (ilist-mappend fn . lsts)
  (ilist-apply ilist-append
               (apply ilist-map fn lsts)))

(define (ilist-map fn . lsts)
  (if (null? lsts)
    (ilist-null)
    (let loop ((lsts lsts) (result (ilist-null)))
      (if (memq #t (map ilist-null? lsts))
        (ilist-reverse result)
        (loop (map ilist-rest lsts)
              (ilist-cons (apply fn (map ilist-first lsts))
                      result))))))

(define (ilist-for-each fn . lsts)
  (unless (null? lsts)
    (do ((lsts lsts (map ilist-rest lsts)))
      ((memq #t (map ilist-null? lsts)))
      (apply fn (map ilist-first lsts)))))

(define (ilist-filter ok? lst)
  (let loop ((ls lst) (yes (ilist-null)) (no (ilist-null)))
    (cases ilist ls
      (ilist-null ()
        (values (ilist-reverse yes) (ilist-reverse no)))
      (ilist-cons (first rest)
         (if (ok? first)
           (loop rest (ilist-cons first yes) no)
           (loop rest yes (ilist-cons first no)))))))

(define (ilist-equal? lst0 lst1)
  (let loop ((ls0 lst0) (ls1 lst1))
    (cond
      ((ilist-null? ls0)
       (ilist-null? ls1))
      ((ilist-null? ls1)
       (ilist-null? ls0))
      (else
        (and (equ? (ilist-first ls0)
                    (ilist-first ls1))
             (loop (ilist-rest ls0)
                   (ilist-rest ls1)))))))

(define (ilist-memp ok? lst)
  (let loop ((ls lst))
    (cases ilist ls
      (ilist-null () #f)
      (ilist-cons (first rest)
         (if (ok? first)
           ls
           (loop rest))))))

(define (ilist-member item lst)
  (ilist-memp (lambda (x) (equ? x item)) lst))

(define (ilist-remp ok? lst)
  (call-with-values (lambda () (ilist-filter ok? lst))
                    (lambda (a b) b)))

(define (ilist-remove item lst)
  (ilist-remp (lambda (x) (equ? item x)) lst))

(define (ilist-adjoin item lst)
  (if (ilist-member item lst)
    lst
    (ilist-cons item lst)))

(define (ilist-remove-dups lst)
  (let loop ((ls lst) (result (ilist-null)))
    (cases ilist ls
      (ilist-null () result)
      (ilist-cons (first rest)
              (loop rest (ilist-adjoin first result))))))

(define (ilist-assp ok? lst)
  (let loop ((ls lst))
    (cases ilist ls
      (ilist-null () #f)
      (ilist-cons (first rest)
        (if (ok? (car first))
          first
          (loop rest))))))

(define (ilist-assoc item lst)
  (ilist-assp (lambda (x) (equ? item x)) lst))

(define (ilist-fold-left op base . lsts)
  (cond
    ((null? lsts) base)
    ((null? (cdr lsts))
     (let loop ((lst (car lsts)) (result base))
       (if (ilist-null? lst)
         result
         (loop (ilist-rest lst)
               (op result (ilist-first lst))))))
    (else
      (let loop ((lsts lsts) (result base))
        (cond
          (((list-of? ilist-null?) lsts)
           result)
          (((list-of? (o not ilist-null?)) lsts)
           (loop (map ilist-rest lsts)
                 (apply op result (map ilist-first lsts))))
          (else
            (error 'ilist-fold-left "lists not of equal length")))))))

(define (ilist-fold-right op base . lsts)
  (cond
    ((null? lsts) base)
    ((null? (cdr lsts))
     (let loop ((lst (ilist-reverse (car lsts)))
                (result base))
       (if (ilist-null? lst)
         result
         (loop (ilist-rest lst)
               (op (ilist-first lst) result)))))
    (else
      (let loop (
        ;; checking for equal length is done by ilist-reverse
        (lsts (call-with-values
                (lambda () (apply ilist-reverse lsts))
                list))
        (result base)
        )
        (if ((list-of? ilist-null?) lsts)
          result
          (loop (map ilist-rest lsts)
                (apply op
                       (append (map ilist-first lsts)
                               (list result)))))))))

(define (ilist-merge <? lst0 lst1)
  ;; without sorted checks, not tail recursive
  ;(let loop ((ls0 lst0) (ls1 lst1))
  ;  (cond
  ;    ((ilist-null? ls0) ls1)
  ;    ((ilist-null? ls1) ls0)
  ;    ((<? (ilist-first ls0) (ilist-first ls1))
  ;     (ilist-cons (ilist-first ls0)
  ;             (loop (ilist-rest ls0) ls1)))
  ;    (else
  ;     (ilist-cons (ilist-first ls1)
  ;             (loop ls0 (ilist-rest ls1)))))))
  ;; tail recursive, with sorted checks
  (let loop ((ls0 lst0) (ls1 lst1) (result (ilist-null)))
    (cond
      ((and (ilist-null? ls0) (ilist-null? ls1))
       (ilist-reverse result))
      ((ilist-null? ls0)
       (if (or (ilist-null? (ilist-rest ls1))
               (<? (ilist-first ls1) (ilist-first (ilist-rest ls1))))
         (loop ls0 (ilist-rest ls1) (ilist-cons (ilist-first ls1) result))
         (error 'ilist-merge "not sorted" lst1)))
      ((ilist-null? ls1)
       (if (or (ilist-null? (ilist-rest ls0))
               (<? (ilist-first ls0) (ilist-first (ilist-rest ls0))))
         (loop (ilist-rest ls0) ls1 (ilist-cons (ilist-first ls0) result))
         (error 'ilist-merge "not sorted" lst1)))
      ((not (or (ilist-null? (ilist-rest ls0))
                (<? (ilist-first ls0) (ilist-first (ilist-rest ls0)))))
       (error 'ilist-merge "not sorted" lst0))
      ((not (or (ilist-null? (ilist-rest ls1))
                (<? (ilist-first ls1) (ilist-first (ilist-rest ls1)))))
       (error 'ilist-merge "not sorted" lst1))
      (else
        (if (<? (ilist-first ls0) (ilist-first ls1))
          (loop (ilist-rest ls0) ls1 (ilist-cons (ilist-first ls0) result))
          (loop ls0 (ilist-rest ls1) (ilist-cons (ilist-first ls1) result))))
      )))

(define (ilist-merge-sort <? lst)
  (let loop ((ls lst))
    (let ((len (ilist-length ls)))
      (if (< len 2)
        ls
        (receive (head tail)
          (ilist-split-at (quotient len 2) ls)
          (ilist-merge <?
                   (loop head)
                   (loop tail)))))))

(define (ilist-insertion-sort <? lst)
  (cases ilist lst
    (ilist-null () lst)
    (ilist-cons (first rest)
      (ilist-insert-sorted <?
                           first
                           (ilist-insertion-sort <? rest)))))

(define (ilist-sorted? <? lst)
  (let loop ((ls lst))
    (cases ilist ls
      (ilist-null () #t)
      (ilist-cons (first rest)
        (cond
          ((ilist-null? rest) #t)
          ((<? first (ilist-first rest))
           (loop rest))
          (else #f))))))

(define (ilist-insert-sorted <? item lst)
  (if (ilist-sorted? <? lst)
    (let loop ((lst lst))
      (cases ilist lst
        (ilist-null () (ilist-cons item (ilist-null)))
        (ilist-cons (first rest)
          (if (<? item first)
            (ilist-apply ilist item first rest)
            (ilist-cons first (loop rest))))))
    (error 'ilist-insert-sorted "argument list not sorted" lst)))

(define (ilist-zip lst0 lst1)
  (cond
    ((ilist-null? lst0)
     lst1)
    (else
      (ilist-cons (ilist-first lst0)
              (ilist-zip lst1 (ilist-rest lst0))))))

(define (ilist-unzip lst)
  (let loop ((lst lst)
             (k 0)
             (lst0 (ilist-null))
             (lst1 (ilist-null)))
    (cases ilist lst
      (ilist-null ()
        (values (ilist-reverse lst0)
                (ilist-reverse lst1)))
      (ilist-cons (first rest)
        (if (even? k)
          (loop rest
                (+ k 1)
                (ilist-cons first lst0)
                lst1)
          (loop rest
                (+ k 1)
                lst0
                (ilist-cons first lst1)))))))

(define (ilist-interpose sep lst)
  (ilist-rest
    (let loop ((ls lst) (result (ilist-null)))
      (cases ilist ls
        (ilist-null () (ilist-reverse result))
        (ilist-cons (first rest)
          (loop rest
                (ilist-cons first (ilist-cons sep result))))))))
                ;(ilist-apply ilist first sep result)))))))

(define (ilist-every? ok? lst)
  (not (ilist-memp (o not ok?) lst)))

(define (ilist-not-every? ok? lst)
  (if (ilist-memp (o not ok?) lst) #t #f))

(define (ilist-not-any? ok? lst)
  (if (ilist-memp ok? lst)
    #f
    #t))

(define (ilist-some ok? lst)
  (let loop ((ls lst))
    (cases ilist ls
      (ilist-null () #f)
      (ilist-cons (first rest)
         (if (ok? first)
           first
           (loop rest))))))

(define (ilist-in? ilst1 ilst2)
  (cases ilist ilst1
    (ilist-null () #t)
    (ilist-cons (first rest)
      (let ((start (ilist-member first ilst2)))
        (if start
          (let loop ((ls0 ilst1) (ls1 start))
            (cond
              ((and (ilist-null? ls0) (ilist-null? ls1)) #t)
              ((ilist-null? ls0) #t)
              ((ilist-null? ls1) #f)
              ((equ? (ilist-first ls0) (ilist-first ls1))
               (loop (ilist-rest ls0) (ilist-rest ls1)))
              (else #f)))
          #f)))))

;;; documentation
(define ilists
  (let (
    (signatures '(
      (ilist? xpr)
      (ilist . args)
      (list->ilist lst)
      (ilist-null)
      (ilist-cons item ilst)
      (ilist-repeat n x)
      (ilist-iterate n fn x)
      (ilist-iterate-while ok? fn x)
      (ilist-iterate-until ok? fn x)

      (ilist->list ilst)
      (ilist-apply fn . args)
      (ilist-null? xpr)
      (ilist-first ilst)
      (ilist-rest ilst)
      (ilist-reverse . ilsts)
      (ilist-length ilst)
      (ilist-from-upto from upto ilst) ; sublist
      (ilist-item k ilst) ; ref
      (ilist-split-at k ilst)
      (ilist-split-with ok? ilst)
      (ilist-drop k ilst)
      (ilist-drop-while ok? ilst)
      (ilist-take k ilst)
      (ilist-take-while ok? ilst)
      (ilist-append . ilsts)
      (ilist-map fn . ilsts)
      (ilist-mappend fn . ilsts)
      (ilist-for-each fn . ilsts)
      (ilist-filter ok? ilst)
      (ilist-adjoin item ilst)
      (ilist-equal? ilst0 ilst1)
      (ilist-memp ok? ilst)
      (ilist-member item ilst)
      (ilist-remp ok? ilst)
      (ilist-remove item ilst)
      (ilist-remove-dups ilst)
      (ilist-assp ok? ilst)
      (ilist-assoc item ilst)
      (ilist-fold-left op base . ilsts)
      (ilist-fold-right op base . ilsts)
      (ilist-merge <? ilst0 ilst1)
      (ilist-merge-sort <? ilst)
      (ilist-insertion-sort <? ilst)
      (ilist-sorted? <? ilst)
      (ilist-insert-sorted <? item ilst)
      (ilist-zip ilst0 ilst1)
      (ilist-unzip ilst)
      (ilist-interpose sep ilst)
      (ilist-every? ok? ilst)
      (ilist-some ok? ilst)
      (ilist-not-every? ok? ilst)
      (ilist-not-any? ok? ilst)
      (ilist-in? ilst0 ilst1)
      (ilist-bind (x ... . xs) ilst xpr . xprs)
      ))
    )
    (case-lambda
      (() (map car signatures))
      ((sym) (assq sym signatures)))))

) ; functor list-functor

(functor (set-functor (M (item? equ?)) (N LISTS)) SETS

(import scheme
        (only chicken error define-record-printer case-lambda)
        (only extras sprintf)
        datatype
        M N)

;;; sets as ilists

(define-datatype set set?
  (ilist->set (ls ilist?)))

(define (set-add item st)
  (ilist->set
    (cases set st
      (ilist->set (ls)
         (ilist-cons item ls)))))
  
(define (set-remove item st)
  (ilist->set
    (cases set st
      (ilist->set (ls)
        (cases ilist ls
          (ilist-null ()
            (ilist-null))
          (ilist-cons (first rest)
            (if (equ? item first)
              (ilist-remove item rest)
              (ilist-cons first
                         (ilist-remove item rest)))))))))
      
(define (set->ilist st)
  (cases set st
    (ilist->set (st) st)))

(define-record-printer (set st out)
  (let ((str (sprintf "~s"
               (ilist->list
                 (cases set st
                   (ilist->set (ls)
                     (ilist-remove-dups ls)))))))
    (string-set! str 0 #\{)
    (string-set! str (- (string-length str) 1) #\})
    (display str out)))

(define (set . args)
  (ilist->set (apply ilist args)))

(define (set-cardinality st)
  (cases set st
    (ilist->set (ls)
       (ilist-length (ilist-remove-dups ls)))))

(define (set-in? item st)
  (cases set st
    (ilist->set (ls)
      (if (ilist-member item ls) #t #f))))

(define (set<= set0 set1)
  (cases set set0
    (ilist->set (ls0)
      (ilist-every?
        (lambda (item)
          (ilist-member
            item
            (cases set set1
              (ilist->set (ls1)
                          ls1))))
        ls0))))

(define (set>= set0 set1) (set<= set1 set0))

(define (set= set0 set1)
  (and (set<= set0 set1)
       (set<= set1 set0)))

;; ilist-filter not used, to avoid unnessecary reversing
(define (set-filter ok? st)
  (cases set st
    (ilist->set (ls)
      (let loop ((ls ls) (yes (ilist-null)) (no (ilist-null)))
        (cases ilist ls
          (ilist-null ()
            (values (ilist->set yes) (ilist->set no)))
          (ilist-cons (first rest)
            (if (ok? first)
              (loop rest (ilist-cons first yes) no)
              (loop rest yes (ilist-cons first no)))))))))

(define (set-null? xpr)
  (and (set? xpr)
       (cases set xpr
         (ilist->set (ls) (ilist-null? ls)))))

(define (set-difference set0 set1)
  (let loop ((ls1 (set->ilist  set1))
             (ls0 (set->ilist set0)))
    (cases ilist ls1
      (ilist-null () (ilist->set ls0))
      (ilist-cons (first rest)
        (loop rest (ilist-remove first ls0))))))

;; ilist-append not used, ilist-o avoid unnessecary reversing
(define (set-union . sts)
  (cond
    ((null? sts) (ilist->set (ilist-null)))
    ((null? (cdr sts)) (car sts))
    ((null? (cddr sts))
     (cases set (car sts)
       (ilist->set (ls)
         (let loop ((ls ls) (result (cadr sts)))
           (cases ilist ls
             (ilist-null () result)
             (ilist-cons (first rest)
               (loop rest
                     (set-add first result))))))))
    (else
      (set-union (car sts)
                   (apply set-union (cdr sts))))))

(define (set-intersection . sts)
    (cond
      ((null? sts)
       (ilist->set (ilist-null)))
      ((null? (cdr sts))
       (car sts))
      ((null? (cddr sts))
       (let ((set1 (cadr sts)))
         (cases set (car sts)
           (ilist->set (ls)
             (let loop ((ls ls)
                        (result (ilist-null)))
               (cases ilist ls
                 (ilist-null () (ilist->set result))
                 (ilist-cons (first rest)
                   (if (set-in? first set1)
                     (loop rest
                           (ilist-cons first result))
                     (loop rest result)))))))))
      (else
        (set-intersection (car sts)
                            (apply set-intersection (cdr sts))))))

;; documentation procedure
(define sets
  (let (
    (signatures '(
      (set? xpr)
      (set . args)
      (ilist->set lst)
      (set->ilist st)
      (set-in? item st)
      (set<= set0 set1)
      (set= set0 set1)
      (set>= set0 set1)
      (set-filter ok? st)
      (set-null? xpr)
      (set-add item st)
      (set-remove item st)
      (set-cardinality st)
      (set-difference set0 set1)
      (set-union . sts)
      (set-intersection . sts)
      ))
    )
    (case-lambda
      (() (map car signatures))
      ((sym) (assq sym signatures)))))

) ; functor set-functor

;;; implicit functor argument _immutable-lists
(module immutable-lists = list-functor
  (import scheme
          (only chicken case-lambda))

  (define item? (lambda (x) #t))
  (define equ? equal?)
  ) ; immutable-lists



;;; explicit functor arguments
(module sets = (set-functor _immutable-lists immutable-lists))