Pascal J. Bourguignon [2013-05-12 01:44]
```Added SET and INDEX-SET.
```
```diff --git a/common-lisp/cesarum/array.lisp b/common-lisp/cesarum/array.lisp
index ded2132..9aa2f66 100644
--- a/common-lisp/cesarum/array.lisp
+++ b/common-lisp/cesarum/array.lisp
@@ -43,8 +43,11 @@
(:use "COMMON-LISP")
(:export
"POSITIONS" ; should go to a sequence package...
-   "VECTOR-DELETE"
+
+   "VECTOR-EMPTYP" "VECTOR-FIRST" "VECTOR-LAST" "VECTOR-REST"
+   "VECTOR-BUTLAST" "VECTOR-DELETE"
"NUDGE-DISPLACED-VECTOR" "DISPLACED-VECTOR"
+
"ARRAY-TO-LIST" "COPY-ARRAY"
"ARRAY-EQUAL-P")
(:documentation
@@ -110,6 +113,60 @@ EXAMPLE:    (positions 'a #(a door a window a big hole and a bucket) :start 1)
:collect p))))

+
+(defun vector-emptyp (vector)
+  "
+RETURN:  Whether the vector is empty.
+"
+  (zerop (length vector)))
+
+
+(defun vector-first (vector)
+  "
+RETURN: The first element of the vector, or 0 values if empty.
+"
+  (if (plusp (length vector))
+      (aref vector 0)
+      (values)))
+
+
+(defun vector-last (vector)
+  "
+RETURN: The last element of the vector, or 0 values if empty.
+"
+  (if (plusp (length vector))
+      (aref vector (1- (length vector)))
+      (values)))
+
+
+(defun vector-rest (vector)
+  "
+RETURN: A displaced, adjustable array, with fill-pointer,  covering all the elements of the VECTOR but the first.
+"
+  (let* ((emptyp (vector-emptyp vector))
+         (size   (if emptyp 0 (1- (length vector)))))
+    (make-array size
+                :element-type (array-element-type vector)
+                :displaced-to vector
+                :dispalced-index-offset (if emptyp 0 1)
+                :fill-pointer size)))
+
+
+(defun vector-butlast (vector)
+  "
+RETURN: A displaced, adjustable array, with fill-pointer, covering all the elements of the VECTOR but the last.
+"
+  (let* ((emptyp (vector-emptyp vector))
+         (size   (if emptyp 0 (1- (length vector)))))
+    (make-array size
+                :element-type (array-element-type vector)
+                :displaced-to vector
+                :dispalced-index-offset 0
+                :fill-pointer size)))
+
+
(defun vector-delete (item vector &rest keys &key (from-end nil) (test 'eql) (test-not nil) (start 0) (end nil) (count nil) (key 'identity))
"
DO:         Delete occurences of ITEM from the VECTOR.  The occurences
diff --git a/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd b/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd
index e9d9d17..2859085 100644
--- a/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd
+++ b/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd
@@ -83,6 +83,9 @@ all written in 100% conforming Common Lisp.
:depends-on (:com.informatimago.common-lisp.lisp-sexp)
#+asdf-unicode :encoding #+asdf-unicode :utf-8
:components (
+                 ;; Simple Test Framework
+                 (:file "simple-test"     :depends-on ())
+
(:file "utility"         :depends-on ())
(:file "array"           :depends-on ())
@@ -92,7 +95,9 @@ all written in 100% conforming Common Lisp.
(:file "package"         :depends-on ("utility"))

;; Data structures:
-                 (:file "bset"            :depends-on ("utility"))
+                 (:file "set"             :depends-on ("simple-test" "utility" "array"))
+                 (:file "index-set"       :depends-on ("simple-test" "utility" "array" "sequence" "set"))
+                 (:file "bset"            :depends-on ("utility" "set"))
(:file "brelation"       :depends-on ("utility" "bset"))
(:file "dictionary"      :depends-on ())
(:file "dll"             :depends-on ())
diff --git a/common-lisp/cesarum/index-set.lisp b/common-lisp/cesarum/index-set.lisp
new file mode 100644
index 0000000..9685064
--- /dev/null
+++ b/common-lisp/cesarum/index-set.lisp
@@ -0,0 +1,690 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               index-set.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Implements a set of indexes, represented as a list of ranges.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2013-05-08 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(in-package "COMMON-LISP-USER")
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.INDEX-SET"
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SEQUENCE"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SET")
+  (:export
+   "CONTAINS" "CARDINAL" "EMPTYP" "MINIMUM" "MAXIMUM"
+   "MAKE-COLLECTOR" "MAPELEMENTS" "THEREIS" "THEREIS1" "ALWAYS"
+   "SET-EQUAL" "IS-SUBSET" "IS-STRICT-SUBSET" "INTENSION" "COPY"
+   "UNION" "INTERSECTION" "DIFFERENCE" "SYMETRIC-DIFFERENCE" "INCLUDE"
+   "EXCLUDE" "ASSIGN-EMPTY" "ASSIGN-SINGLETON" "ASSIGN" "MERGE"
+   "INTERSECT" "SUBTRACT")
+
+  (:export
+   "INDEX-SET"
+
+   "RANGE" "MAKE-RANGE" "RANGE-EMPTYP" "RANGE-START" "RANGE-LAST"
+   "RANGE-END"  "RANGE-COUNT" "RANGE-COPY" "EQUAL-RANGE")
+
+  (:documentation
+   "
+
+This package implements sets of (integer 0 *) as a sequence of ranges.
+
+
+    AGPL3
+
+    Copyright Pascal J. Bourguignon 2013 - 2013
+
+    This program is free software: you can redistribute it and/or modify
+    the Free Software Foundation, either version 3 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU Affero General Public License for more details.
+
+    You should have received a copy of the GNU Affero General Public License
+    along with this program.
+"))
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.INDEX-SET")
+
+
+
+;;;=====================================================================
+;;; RANGE CLASS
+
+(defclass range ()
+  ((start :initarg :start :initform 0 :type integer :writer (setf range-start)
+          :documentation "First element in the range.")
+   (end   :initarg :end   :initform 0 :type integer :writer (setf range-end)
+          :documentation "First element beyond the range.")))
+
+(defmethod print-object ((range range) stream)
+  (print-unreadable-object (range stream :type t)
+    ;; (format stream "~{~S~^ ~}" (list :start (slot-value range 'start)
+    ;;                                  :end   (slot-value range 'end)))
+    (if (range-emptyp range)
+        (princ "empty" stream)
+        (format stream "~A-~A" (range-first range) (range-last range))))
+  range)
+
+(defun exactly-one (&rest parameters)
+  (= 1 (count nil parameters :key (function not))))
+
+(defun make-range (&key start end first last count)
+  (assert (or (and (exactly-one start first)
+                   (exactly-one end last count))
+              (and (exactly-one start first count)
+                   (exactly-one end last))))
+  (make-instance 'range
+      :start (cond (start start)
+                   (first first)
+                   (end (- end count))
+                   (t   (- last count -1)))
+      :end   (cond (end end)
+                   (last (1+ last))
+                   (count (+ start count)))))
+
+(defgeneric range-emptyp (range)
+  (:method ((range range))
+    (<= (slot-value range 'end) (slot-value range 'start))))
+
+(defgeneric range-count (range)
+  (:method ((range range))
+    (max 0 (- (range-end range) (range-start range)))))
+
+(defgeneric range-start (range)
+  (:method ((range range))
+    (unless (range-emptyp range)
+      (slot-value range 'start))))
+
+(defgeneric range-end (range)
+  (:method ((range range))
+    (unless (range-emptyp range)
+      (slot-value range 'end))))
+
+(defgeneric range-first (range)
+  (:method ((range range))
+    (unless (range-emptyp range)
+      (slot-value range 'start))))
+
+(defgeneric range-last (range)
+  (:method ((range range))
+    (unless (range-emptyp range)
+      (1- (slot-value range 'end)))))
+
+(defgeneric copy-range (range)
+  (:method ((range range))
+    (make-instance 'range
+        :start (slot-value range 'start)
+        :end (slot-value range 'end))))
+
+(defgeneric equal-range (r1 r2)
+  (:method ((r1 range) (r2 range))
+    (or (and (range-emptyp r1) (range-emptyp r2))
+        (and (= (range-start r1) (range-start r2))
+             (= (range-end   r1) (range-end   r2))))))
+
+;;----------------------------------------------------------------------
+;; RANGE TESTS
+
+(define-test test/range ()
+  (assert-true (range-emptyp (make-range :start 1 :count 0)))
+  (assert-true (range-emptyp (make-range :start 1 :last 0)))
+  (assert-true (range-emptyp (make-range :start 1 :end 1)))
+  (assert-true (not (range-emptyp (make-range :start 1 :count 1))))
+  (assert-true (not (range-emptyp (make-range :start 1 :last 1))))
+  (assert-true (not (range-emptyp (make-range :start 1 :end 2))))
+  (assert-true (equal-range (make-range :start 10 :end 21)
+                            (make-range :first 10 :last 20)))
+  (assert-true (equal-range (make-range :start 0 :end -1)
+                            (make-range :first 0 :last -1)))
+
+  (test = (range-start (make-range :start 1 :count 3)) 1)
+  (test = (range-last  (make-range :start 1 :count 3)) 3)
+  (test = (range-end   (make-range :start 1 :count 3)) 4)
+  (test = (range-count (make-range :start 1 :count 3)) 3)
+  (test = (range-start (copy-range (make-range :start 1 :count 3))) 1)
+  (test = (range-last  (copy-range (make-range :start 1 :count 3))) 3)
+  (test = (range-end   (copy-range (make-range :start 1 :count 3))) 4)
+  (test = (range-count (copy-range (make-range :start 1 :count 3))) 3)
+
+  (test = (range-start (make-range :start 11 :last 13)) 11)
+  (test = (range-last  (make-range :start 11 :last 13)) 13)
+  (test = (range-end   (make-range :start 11 :last 13)) 14)
+  (test = (range-count (make-range :start 11 :last 13))  3)
+  (test = (range-start (copy-range (make-range :start 11 :last 13))) 11)
+  (test = (range-last  (copy-range (make-range :start 11 :last 13))) 13)
+  (test = (range-end   (copy-range (make-range :start 11 :last 13))) 14)
+  (test = (range-count (copy-range (make-range :start 11 :last 13)))  3)
+
+  (test = (range-start (make-range :start 11 :end 14)) 11)
+  (test = (range-last  (make-range :start 11 :end 14)) 13)
+  (test = (range-end   (make-range :start 11 :end 14)) 14)
+  (test = (range-count (make-range :start 11 :end 14))  3)
+  (test = (range-start (copy-range (make-range :start 11 :end 14))) 11)
+  (test = (range-last  (copy-range (make-range :start 11 :end 14))) 13)
+  (test = (range-end   (copy-range (make-range :start 11 :end 14))) 14)
+  (test = (range-count (copy-range (make-range :start 11 :end 14)))  3)
+
+  (test = (range-start (make-range :count 3 :last 13)) 11)
+  (test = (range-last  (make-range :count 3 :last 13)) 13)
+  (test = (range-end   (make-range :count 3 :last 13)) 14)
+  (test = (range-count (make-range :count 3 :last 13))  3)
+  (test = (range-start (copy-range (make-range :count 3 :last 13))) 11)
+  (test = (range-last  (copy-range (make-range :count 3 :last 13))) 13)
+  (test = (range-end   (copy-range (make-range :count 3 :last 13))) 14)
+  (test = (range-count (copy-range (make-range :count 3 :last 13)))  3)
+
+  (test = (range-start (make-range :count 3 :end 14)) 11)
+  (test = (range-last  (make-range :count 3 :end 14)) 13)
+  (test = (range-end   (make-range :count 3 :end 14)) 14)
+  (test = (range-count (make-range :count 3 :end 14))  3)
+  (test = (range-start (copy-range (make-range :count 3 :end 14))) 11)
+  (test = (range-last  (copy-range (make-range :count 3 :end 14))) 13)
+  (test = (range-end   (copy-range (make-range :count 3 :end 14))) 14)
+  (test = (range-count (copy-range (make-range :count 3 :end 14)))  3))
+
+
+;;;=====================================================================
+;;; INDEX-SET CLASS
+
+(defclass index-set ()
+  ((ranges :initform #() :type vector :initarg ranges)))
+;; Invariants:
+;; no empty range
+;; ∀i∈[0 .. (1- (length ranges))[, (< (range-end (aref ranges i)) (range-start (aref ranges (1+ i))))
+
+(defmethod print-object ((set index-set) stream)
+  (print-unreadable-object (set  stream :identity t :type t)
+    (format stream "~{~S~^ ~}" (coerce (slot-value set 'ranges) 'list)))
+  set)
+
+
+(defun index-set (&rest elements)
+  (copy 'index-set elements))
+
+(defmethod check-invariant ((set index-set))
+  (assert (slot-boundp set 'ranges))
+  (let ((ranges (slot-value set 'ranges)))
+    (check-type ranges vector)
+    (notany (function range-emptyp) ranges)
+    (when (<= 2 (length ranges))
+      (assert
+       (loop
+         :for i :below (1- (length ranges))
+         :always (< (range-end (aref ranges i)) (range-start (aref ranges (1+ i)))))))))
+
+
+(defmethod emptyp              ((set index-set))
+  (vector-emptyp (slot-value set 'ranges)))
+
+(defmethod cardinal              ((set index-set))
+  (reduce (function +) (slot-value set 'ranges) :key (function range-count)))
+
+(defmethod minimum               ((set index-set))
+  (unless (emptyp set)
+    (range-start (aref (slot-value set 'ranges) 0))))
+
+(defmethod maximum               ((set index-set))
+  (unless (emptyp set)
+    (range-last (vector-last (slot-value set 'ranges)))))
+
+
+(defgeneric range-of-element (set element)
+  (:method ((set index-set) element)
+    (check-type element integer)
+    (dichotomy-search (slot-value set 'ranges)
+                      element
+                      (lambda (element range)
+                        (cond
+                          ((< element (range-start range)) -1)
+                          ((< element (range-end range))    0)
+                          (t                               +1))))))
+
+(defmethod contains              ((set index-set) element)
+  (declare (ignore element))
+  nil)
+
+(defmethod contains              ((set index-set) (element integer))
+  (values (range-of-element set element)))
+
+
+(defmethod make-collector        ((result-type (eql 'index-set)))
+  (declare (ignorable result-type))
+  (lambda (&optional set (element nil add-element-p))
+        (include set element)
+        (make-instance 'index-set))))
+
+
+(defmethod mapelements           (result-type mapper (set index-set))
+  (collecting-result (collect result-type)
+    (loop
+      :for range :across (slot-value set 'ranges)
+      :do (loop
+            :for element :from (range-start range) :below (range-end range)
+            :do (collect (funcall mapper element))))))
+
+
+(defmethod set-equal              ((set1 index-set) (set2 index-set))
+  (and (= (length (slot-value set1 'ranges)) (length (slot-value set2 'ranges)))
+       (loop
+         :for r1 :across (slot-value set1 'ranges)
+         :for r2 :across (slot-value set2 'ranges)
+         :always (equal-range r1 r2))))
+
+
+(defmethod is-subset             ((set1 index-set) (set2 index-set))
+  (loop
+    :for range :across (slot-value set1 'ranges)
+    :always (multiple-value-bind (f1 i1) (range-of-element set2 (range-start range))
+              (multiple-value-bind (f2 i2) (range-of-element set2 (range-last range))
+                (and f1 f2 (= i1 i2))))))
+
+(defmethod is-strict-subset      ((set1 index-set) (set2 index-set))
+  (and (< (cardinal set1) (cardinal set2))
+       (is-subset set1 set2)))
+
+(defmethod copy                  ((result-type (eql 'index-set)) source-set)
+  (assign (make-instance 'index-set) source-set))
+
+
+;;-----------------------------------------------------------------------
+;; Algorithms
+
+(defun complement-ranges (ranges start end)
+  (assert (or (vector-emptyp ranges)
+              (and (<= start (range-start (vector-first ranges)))
+                   (<= (range-end (vector-last ranges)) end))))
+  (cond
+    ((vector-emptyp ranges)
+     (vector (make-range :start start :end end)))
+    (t
+     (loop
+       :with len = (length ranges)
+       :with result = (make-array (1+ len) :fill-pointer 0 :adjustable t)
+       :for r :across ranges
+       :do (progn
+             (unless (= start (range-start r))
+               (vector-push-extend (make-range :start start :end (range-start r)) result (length result)))
+             (setf start (range-end r)))
+       :finally (progn
+                  (unless (= start end)
+                    (vector-push-extend (make-range :start start :end end) result (length result)))
+                  (return result))))))
+
+
+(defun merge-ranges (a b)
+  (cond
+    ((vector-emptyp b) a)
+    ((vector-emptyp a) b)
+    (t
+     (loop
+       :with lena = (length a)
+       :with lenb = (length b)
+       :with result = (make-array (+ lena lenb) :fill-pointer 0 :adjustable t)
+       :with a-is-smallest =  (< (range-start (aref a 0))
+                                 (range-start (aref b 0)))
+       :with current = (copy-range (aref (if a-is-smallest a b) 0))
+       :with i = (if a-is-smallest 1 0)
+       :with j = (if a-is-smallest 0 1)
+       :do (progn
+             (loop
+               :with merge-a
+               :while (or (setf merge-a (and (< i lena)
+                                             (<= (range-start (aref a i)) (range-end current))))
+                          (and (< j lenb)
+                               (<= (range-start (aref b j)) (range-end current))))
+               :do (if merge-a
+                       (progn
+                         (setf (range-end current) (range-end (aref a i)))
+                         (incf i))
+                       (progn
+                         (setf (range-end current) (range-end (aref b j)))
+                         (incf j))))
+             (vector-push-extend current result (length result))
+             (if (and (< i lena) (< j lenb))
+                 (if (< (range-start (aref a i)) (range-start (aref b j)))
+                     (progn
+                       (setf current (copy-range (aref a i)))
+                       (incf i))
+                     (progn
+                       (setf current (copy-range (aref b j)))
+                       (incf j)))
+                 (loop-finish)))
+       :finally (progn
+                  (loop
+                    :while (< i lena)
+                    :do (progn (vector-push-extend (copy-range (aref a i)) result (length result))
+                               (incf i)))
+                  (loop
+                    :while (< j lenb)
+                    :do (progn (vector-push-extend (copy-range (aref b j)) result (length result))
+                               (incf j)))
+                  (return result))))))
+
+
+(defun intersect-ranges (a b)
+  (cond
+    ((vector-emptyp a) a)
+    ((vector-emptyp b) b)
+    (t
+     (loop
+       :with lena = (length a)
+       :with lenb = (length b)
+       :with result = (make-array 4 :fill-pointer 0 :adjustable t)
+       :with i = 0 :with current-a = (aref a i)
+       :with j = 0 :with current-b = (aref b j)
+       :do (progn
+
+             (loop
+               :while (and (< i lena)
+                           (<= (range-end current-a) (range-start current-b)))
+               :do (progn
+                     (incf i)
+                     (setf current-a (when (< i lena) (aref a i)))))
+             (unless current-a (loop-finish))
+
+             (loop
+               :while (and (< j lenb)
+                           (<= (range-end current-b) (range-start current-a)))
+               :do (progn
+                     (incf j)
+                     (setf current-b (when (< j lenb) (aref b j)))))
+             (unless current-b (loop-finish))
+
+             (unless (or (<= (range-end current-a) (range-start current-b))
+                         (<= (range-end current-b) (range-start current-a)))
+               (vector-push-extend (make-range :start (max (range-start current-a)
+                                                           (range-start current-b))
+                                               :end   (min (range-end current-a)
+                                                           (range-end current-b)))
+                                   result (length result))
+               (cond
+                 ((= (range-end current-a) (range-end current-b))
+                  (incf i)
+                  (if (< i lena)
+                      (setf current-a (aref a i))
+                      (loop-finish))
+                  (incf j)
+                  (if (< j lenb)
+                      (setf current-b (aref b j))
+                      (loop-finish)))
+                 ((< (range-end current-a) (range-end current-b))
+                  (incf i)
+                  (if (< i lena)
+                      (setf current-a (aref a i))
+                      (loop-finish)))
+                 (t
+                  (incf j)
+                  (if (< j lenb)
+                      (setf current-b (aref b j))
+                      (loop-finish))))))
+       :finally (return result)))))
+
+
+(defun difference-ranges (r1 r2)
+  (if (or (vector-emptyp r1)
+          (vector-emptyp r2))
+      r1
+      (let* ((start (min (range-start r1) (range-start r2)))
+             (end   (max (range-end   r1) (range-end   r2))))
+        (intersect-ranges r1 (complement-ranges r2 start end)))))
+
+
+(defun symetric-difference-ranges (r1 r2)
+  (cond
+    ((vector-emptyp r1) r2)
+    ((vector-emptyp r2) r1)
+    (t
+     (let* ((start (min (range-start r1) (range-start r2)))
+            (end   (max (range-end   r1) (range-end   r2))))
+       (intersect-ranges (merge-ranges r1 r2) (complement-ranges (intersect-ranges r1 r2) start end))))))
+
+
+(defun collect-ranges (result-type ranges)
+  (collecting-result (collect result-type)
+    (loop
+      :for range :across ranges
+      :do (loop
+            :for element :from (range-start range) :below (range-end range)
+            :do (collect element)))))
+
+
+(defun equal-ranges (a b)
+  (and (vectorp a)
+       (vectorp b)
+       (= (length a) (length b))
+       (every (function equal-range) a b)))
+
+
+(define-test test/range/complement ()
+
+  (test equal-ranges
+        (complement-ranges (vector) 0 100)
+        (vector (make-range :start 0 :end 100)))
+
+  (test equal-ranges
+        (complement-ranges (vector  (make-range :start 0 :end 100)) 0 100)
+        (vector))
+
+  (test equal-ranges
+        (complement-ranges (vector (make-range :start 0 :end 90)) 0 100)
+        (vector (make-range :start 90 :end 100)))
+
+  (test equal-ranges
+        (complement-ranges (vector (make-range :start 10 :end 100)) 0 100)
+        (vector (make-range :start 0 :end 10)))
+
+  (test equal-ranges
+        (complement-ranges (vector (make-range :start 10 :end 90)) 0 100)
+        (vector (make-range :start 0 :end 10)  (make-range :start 90 :end 100)))
+
+  (expect-condition error
+                    (complement-ranges (vector  (make-range :start 0 :end 100)) 10 90)))
+
+
+;;----------------------------------------------------------------------
+;; Functional
+
+(defmethod union                 ((result-type (eql 'index-set)) (set1 index-set) (set2 index-set))
+  (make-instance 'index-set 'ranges (merge-ranges (slot-value set1 'ranges) (slot-value set2 'ranges))))
+
+(defmethod union                 (result-type (set1 index-set) (set2 index-set))
+  (collect-ranges result-type (merge-ranges (slot-value set1 'ranges) (slot-value set2 'ranges))))
+
+(defmethod intersection          ((result-type (eql 'index-set)) (set1 index-set) (set2 index-set))
+  (make-instance 'index-set 'ranges (intersect-ranges (slot-value set1 'ranges) (slot-value set2 'ranges))))
+
+(defmethod intersection          (result-type (set1 index-set) (set2 index-set))
+  (collect-ranges result-type (intersect-ranges (slot-value set1 'ranges) (slot-value set2 'ranges))))
+
+(defmethod difference            ((result-type (eql 'index-set)) (set1 index-set) (set2 index-set))
+  (make-instance 'index-set 'ranges (difference-ranges  (slot-value set1 'ranges) (slot-value set2 'ranges))))
+
+(defmethod difference            (result-type (set1 index-set) (set2 index-set))
+  (collect-ranges result-type (difference-ranges (slot-value set1 'ranges) (slot-value set2 'ranges))))
+
+(defmethod symetric-difference   ((result-type (eql 'index-set)) (set1 index-set) set2)
+  (make-instance 'index-set (symetric-difference-ranges (slot-value set1 'ranges) (slot-value set2 'ranges))))
+
+(defmethod symetric-difference   (result-type (set1 index-set) set2)
+  (collect-ranges result-type (symetric-difference-ranges (slot-value set1 'ranges) (slot-value set2 'ranges))))
+
+;;----------------------------------------------------------------------
+;; Mutation
+
+(defmethod include               ((destination-set index-set) (range range))
+  (unless (range-emptyp range)
+    (merge destination-set (make-instance 'index-set 'ranges (vector range))))
+  destination-set)
+
+(defmethod include               ((destination-set index-set) (element integer))
+  (multiple-value-bind (found index order) (range-of-element destination-set element)
+    (unless found
+      (let ((ranges (slot-value destination-set 'ranges)))
+        (flet ((check-fusion (index)
+                 (when (= (range-end (aref ranges index))
+                          (range-start (aref ranges (1+ index))))
+                   (setf (range-end (aref ranges index)) (range-end (aref ranges (1+ index)))
+                         (slot-value destination-set 'ranges)
+                         (replace-subseq '() ranges index (1+ index))))))
+          (cond
+            ((vector-emptyp ranges)
+             (setf (slot-value destination-set 'ranges)
+                   (vector (make-range :start element :count 1))))
+            ((minusp order)
+             (if (= (1+ element) (range-start (vector-first ranges)))
+                 (decf (range-start (vector-first ranges)))
+                 (setf (slot-value destination-set 'ranges)
+                       (replace-subseq (list (make-range :start element :count 1))
+                                       ranges 0 0))))
+            ((< (1+ (maximum destination-set)) element)
+             (setf (slot-value destination-set 'ranges)
+                   (replace-subseq (list (make-range :start element :count 1))
+                                   ranges (length ranges) (length ranges))))
+            ((< (maximum destination-set) element)
+             (incf (range-end (vector-last ranges))))
+            ((= (1+ element) (range-start (aref ranges (1+ index))))
+             (decf (range-start (aref ranges (1+ index))))
+             (check-fusion index))
+            ((= (range-end (aref ranges index)) element)
+             (incf (range-end (aref ranges index)))
+             (check-fusion index))
+            (t
+             (setf (slot-value destination-set 'ranges)
+                   (replace-subseq (list (make-range :start element :count 1))
+                                   ranges index index))))))))
+  destination-set)
+
+
+(defmethod exclude               ((destination-set index-set) (range range))
+  (unless (range-emptyp range)
+    (subtract destination-set (make-instance 'index-set 'ranges (vector range))))
+  destination-set)
+
+(defmethod exclude               ((destination-set index-set) (element integer))
+  (multiple-value-bind (found index) (range-of-element destination-set element)
+    (when found
+      (let ((ranges (slot-value destination-set 'ranges)))
+        (flet ((check-empty (index)
+                 (when (range-emptyp (aref ranges index))
+                   (setf (slot-value destination-set 'ranges)
+                         (replace-subseq '() ranges index (1+ index))))))
+          (cond
+            ((= element (range-start (aref ranges index)))
+             (incf (range-start (aref ranges index)))
+             (check-empty index))
+            ((= (range-last (aref ranges index)) element)
+             (decf (range-end (aref ranges index)))
+             (check-empty index))
+            (t
+             (let ((new-range (make-range :start (1+ element)
+                                          :end (range-end (aref ranges index)))))
+               (setf (range-end (aref ranges index)) element
+                     (slot-value destination-set 'ranges)
+                     (replace-subseq (list new-range) ranges (1+ index) (1+ index))))))))))
+  destination-set)
+
+
+(defmethod assign-empty          ((destination-set index-set))
+  (setf (slot-value destination-set 'ranges) #())
+  destination-set)
+
+
+(defmethod assign-singleton      ((destination-set index-set) element)
+  (setf (slot-value destination-set 'ranges)
+        (vector (make-range :start element :count 1)))
+  destination-set)
+
+
+(defmethod assign                ((destination-set index-set) (source-set index-set))
+  (setf (slot-value destination-set 'ranges)
+        (map 'vector (function copy-range) (slot-value source-set 'ranges)))
+  destination-set)
+
+
+(defmethod merge                 ((destination-set index-set) (source-set index-set))
+  (let ((merged-ranges (merge-ranges (slot-value destination-set 'ranges)
+                                     (slot-value source-set 'ranges))))
+    (setf (slot-value destination-set 'ranges)
+          (if (eq merged-ranges (slot-value source-set 'ranges))
+              (map-into (make-array (length merged-ranges)
+                                    :fill-pointer (length merged-ranges)
+                        (function copy-range) merged-ranges)
+              merged-ranges)))
+  destination-set)
+
+
+(defmethod intersect             ((destination-set index-set) (source-set index-set))
+  (let ((intersected-ranges (intersect-ranges (slot-value destination-set 'ranges)
+                                              (slot-value source-set 'ranges))))
+    (setf (slot-value destination-set 'ranges)
+          (if (eq intersected-ranges (slot-value source-set 'ranges))
+              (map-into (make-array (length intersected-ranges)
+                                    :fill-pointer (length intersected-ranges)
+                        (function copy-range) intersected-ranges)
+              intersected-ranges)))
+  destination-set)
+
+
+(defmethod subtract              ((destination-set index-set) (source-set index-set))
+  (setf (slot-value destination-set 'ranges)
+        (difference-ranges (slot-value destination-set 'ranges) (slot-value source-set 'ranges)))
+  destination-set)
+
+
+;;----------------------------------------------------------------------
+;; INDEX-SET TESTS
+
+(defun test/all ()
+ (test/range)
+ (test/range/complement)
+ (com.informatimago.common-lisp.cesarum.set::test/all/class 'index-set))
+
+(test/all)
+
+;; (copy 'index-set '(1 2 3 4))
+;; (mapelements 'list 'identity  (copy 'index-set '(1 2 3 4)))
+;; (mapelements 'vector 'identity  (copy 'index-set '(1 2 3 4)))
+;; (copy 'vectorx (copy 'index-set '(1 2 3 4)))
+
+;;;; THE END ;;;;
diff --git a/common-lisp/cesarum/set.lisp b/common-lisp/cesarum/set.lisp
new file mode 100644
index 0000000..fcbf3c9
--- /dev/null
+++ b/common-lisp/cesarum/set.lisp
@@ -0,0 +1,679 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               set.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Defines an abstract SET class API.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2013-05-08 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(in-package "COMMON-LISP-USER")
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SET"
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
+  (:export
+   "CONTAINS" "CARDINAL" "EMPTYP" "MINIMUM" "MAXIMUM"
+   "COLLECTING-RESULT" "MAKE-COLLECTOR" "MAPELEMENTS" "THEREIS"
+   "THEREIS1" "ALWAYS" "SET-EQUAL" "IS-SUBSET" "IS-STRICT-SUBSET"
+   "INTENSION" "COPY" "UNION" "INTERSECTION" "DIFFERENCE"
+   "SYMETRIC-DIFFERENCE" "INCLUDE" "EXCLUDE" "ASSIGN-EMPTY"
+   "ASSIGN-SINGLETON" "ASSIGN" "MERGE" "INTERSECT" "SUBTRACT")
+  (:documentation
+   "
+
+This package defines an abstract set class API.
+
+
+    AGPL3
+
+    Copyright Pascal J. Bourguignon 2013 - 2013
+
+    This program is free software: you can redistribute it and/or modify
+    the Free Software Foundation, either version 3 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU Affero General Public License for more details.
+
+    You should have received a copy of the GNU Affero General Public License
+    along with this program.
+"))
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SET")
+
+
+;; The minimum implementation should define methods for: include
+;; exclude contains cardinal select minimum maximum mapelements
+;; make-collector.  But an efficient implementation will have to
+;; implement specialization for the other generic functions too.
+
+
+(defgeneric contains              (set element)
+  (:method ((set sequence) element)
+    (find element set)))
+
+(defgeneric cardinal              (set)
+  (:method ((set sequence))
+    (length set)))
+
+(defgeneric emptyp              (set)
+  (:method (set)
+    (zerop (cardinal set)))
+  (:method ((set null))
+    t)
+  (:method ((set cons))
+    nil))
+
+
+(defgeneric select                (set)
+  (:documentation "
+PRE:    (not (emptyp SET))
+RETURN: one element from the SET.
+"))
+
+
+;; When the elements are ordered:
+
+(defgeneric minimum               (set)
+    (:documentation "
+PRE:    (not (emptyp SET))
+RETURN: the smallest element of the SET.
+"))
+
+(defgeneric maximum               (set)
+  (:documentation "
+PRE:    (not (emptyp SET))
+RETURN: the biggest element of the SET.
+"))
+
+
+
+;; result-type:
+;;   empty-result: --> set
+;;   include: set element -> set
+
+
+(defgeneric make-collector        (result-type)
+  (:method ((result-type (eql 'nil)))
+    (declare (ignore result-type))
+    (lambda (&optional set element)
+      (declare (ignore set element))
+      (values)))
+  (:method ((result-type (eql 'list)))
+    (declare (ignorable result-type))
+    (lambda (&optional set (element nil add-element-p))
+          (cons element set)
+          '())))
+  (:method ((result-type (eql 'vector)))
+    (declare (ignorable result-type))
+    (lambda (&optional set (element nil add-element-p))
+          (progn
+            (vector-push-extend element set (length set))
+            set)
+          (make-array 2 :element-type 'integer :adjustable t :fill-pointer 0)))))
+
+
+#+emacs (put 'collecting-result 'lisp-indent-function 1)
+(defmacro collecting-result ((collect-operator-name result-type) &body body)
+  (let ((collector (gensym))
+        (result    (gensym)))
+    `(let* ((,collector (make-collector ,result-type))
+            (,result (funcall ,collector)))
+       (flet ((,collect-operator-name (element)
+                (setf ,result (funcall ,collector ,result element))))
+         ,@body)
+       ,result)))
+
+
+(defgeneric mapelements           (result-type mapper set)
+  (:method (result-type mapper (elements sequence))
+    (collecting-result (collect result-type)
+      (map nil
+           (lambda (element)
+             (collect (funcall mapper element)))
+           elements))))
+
+
+(defgeneric thereis               (predicate set)
+  (:method (predicate set)
+    (mapelements nil (lambda (element)
+                       (when (funcall predicate element)
+                         (return-from thereis t)))
+                 set)
+    nil))
+
+
+(defgeneric thereis1              (predicate set)
+  (:method (predicate set)
+    (let ((seen-one nil))
+      (mapelements nil (lambda (element)
+                         (when (funcall predicate element)
+                           (if seen-one
+                               (return-from thereis1)
+                               (setf seen-one t))))
+                   set)
+      seen-one)))
+
+
+(defgeneric always                (predicate set)
+  (:method (predicate set)
+    (mapelements nil (lambda (element)
+                       (unless (funcall predicate element)
+                         (return-from always nil)))
+                 set)
+    t))
+
+
+(defgeneric set-equal             (set1 set2)
+  (:method ((set1 list) (set2 list))
+    (and (subsetp set1 set2)
+         (subsetp set2 set1)))
+  (:method (set1 set2)
+    (and (is-subset set1 set2)
+         (is-subset set2 set1))))
+
+
+(defgeneric is-subset             (subset set)
+  (:method (subset set)
+    (and (<= (cardinal subset) (cardinal set))
+         (always (curry (function contains) set) subset))))
+
+
+(defgeneric is-strict-subset      (subset set)
+  (:method (subset set)
+    (and (< (cardinal subset) (cardinal set))
+         (always (curry (function contains) set) subset))))
+
+
+
+(defgeneric intension             (result-type predicate set)
+  (:documentation "Return a new set containing only the elements of SET that have PREDICATE true.")
+  (:method (result-type predicate set)
+    (collecting-result (collect result-type)
+      (mapelements nil (lambda (element)
+                         (when (funcall predicate element)
+                           (collect element)))
+                   set))))
+
+
+(defgeneric copy                  (result-type set)
+  (:method (result-type set)
+    (mapelements result-type 'identity set)))
+
+
+(defgeneric union                 (result-type set1 set2)
+  (:method (result-type set1 set2)
+    (collecting-result (collect result-type)
+      (mapelements nil (function collect) set1)
+      (mapelements nil (function collect) set2))))
+
+
+(defgeneric intersection          (result-type set1 set2)
+  (:method (result-type set1 set2)
+    (let* ((smallest-is-1  (< (cardinal set1) (cardinal set2)))
+           (smallest (if smallest-is-1
+                         set1
+                         set2))
+           (biggest (if smallest-is-1
+                        set2
+                        set1)))
+      (intension result-type (curry (function contains) biggest) smallest))))
+
+
+(defgeneric difference            (result-type set1 set2)
+  (:method (result-type set1 set2)
+    (intension result-type (complement (curry (function contains) set2)) set1)))
+
+
+(defgeneric symetric-difference   (result-type set1 set2)
+  (:method (result-type set1 set2)
+    (union result-type
+           (difference (class-of set1) set1 set2)
+           (difference (class-of set2) set2 set1))))
+
+
+;;; Mutation
+
+(defgeneric include               (destination-set element)
+  (:documentation "
+POST:   (contains DESTINATION-SET ELEMENT)
+RETURN: DESTINATION-SET
+"))
+
+(defgeneric exclude               (destination-set element)
+    (:documentation "
+POST:   (not (contains DESTINATION-SET ELEMENT))
+RETURN: DESTINATION-SET
+"))
+
+(defgeneric assign-empty          (destination-set)
+  (:documentation "
+POST:   (emptyp DESTINATION-SET))
+RETURN: DESTINATION-SET
+")
+  (:method (destination-set)
+    (loop
+      :until (emptyp destination-set)
+      :do (exclude destination-set (select destination-set)))
+    destination-set))
+
+(defgeneric assign-singleton      (destination-set element)
+  (:documentation "
+POST:   (and (= 1 (cardinal DESTINATION-SET)) (contains DESTINATION-SET ELEMENT))
+RETURN: DESTINATION-SET
+")
+  (:method (destination-set element)
+    (assign-empty destination-set)
+    (include destination-set element)
+    destination-set))
+
+(defgeneric assign                (destination-set source-set)
+  (:documentation "
+POST:   (and (set-equal DESTINATION-SET  SOURCE-SET)
+             (set-equal (old SOURCE-SET) SOURCE-SET))
+RETURN: DESTINATION-SET
+")
+  (:method (destination-set source-set)
+    (assign-empty destination-set)
+    (mapelements nil (lambda (element) (include destination-set element)) source-set)
+    destination-set))
+
+(defgeneric merge                 (destination-set source-set)
+  (:documentation "
+POST:   (and (is-subset SOURCE-SET DESTINATION-SET)
+             (set-equal (old SOURCE-SET) SOURCE-SET))
+RETURN: DESTINATION-SET
+")
+  (:method (destination-set source-set)
+    (mapelements nil (curry (function include) destination-set) source-set)
+    destination-set))
+
+(defgeneric intersect             (destination-set source-set)
+  (:documentation "
+POST:   (and (set-equal DESTINATION-SET (intersection (old DESTINATION-SET) SOURCE-SET))
+             (set-equal (old SOURCE-SET) SOURCE-SET))
+RETURN: DESTINATION-SET
+")
+  (:method (destination-set source-set)
+    (mapelements nil (lambda (element)
+                       (unless (contains source-set element)
+                         (exclude destination-set element)))
+                 destination-set)
+    destination-set))
+
+(defgeneric subtract              (destination-set source-set)
+  (:documentation "
+POST:   (and (set-equal DESTINATION-SET (difference (old DESTINATION-SET) SOURCE-SET))
+             (set-equal (old SOURCE-SET) SOURCE-SET))
+RETURN: DESTINATION-SET
+")
+  (:method (destination-set source-set)
+    (mapelements nil (curry (function exclude) destination-set) source-set)
+    destination-set))
+
+
+
+;;; I/O
+
+
+;; Note: different set could be serialized differently.
+
+  (:documentation "
+DO:      Accumulate in SET the elements read from the stream as a list.
+RETURN:  SET.
+")
+  (:method (set stream)
+    (assign-empty set)
+    (when (peek-char (character "(") stream nil nil)
+      (do ()
+          ((char= (peek-char t stream nil (character ")")) (character ")")))
+    set))
+
+
+(defgeneric write-set (set stream)
+  (:documentation "
+DO:     Writes to the stream the elements in SET as a list of elements.
+RETURN: SET.
+")
+  (:method (set stream)
+    (princ "(" stream)
+    (let ((separator ""))
+      (mapelements nil
+                   (lambda (element)
+                     (princ separator stream)
+                     (princ element stream)
+                     (setf separator " "))
+                   set))
+    (princ ")" stream)
+    set))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; LIST-SET CLASS
+;;;
+;;; A simple implementation to test the default methods.
+;;;
+
+(defclass list-set ()
+  ((elements :initform '() :initarg :elements :reader elements)))
+
+(defmethod print-object ((set list-set) stream)
+  (print-unreadable-object (set stream :type t :identity t)
+    (prin1 (slot-value set 'elements) stream))
+  set)
+
+(defmethod include               ((destination-set list-set) element)
+  (pushnew element (slot-value destination-set 'elements))
+  destination-set)
+
+(defmethod exclude               ((destination-set list-set) element)
+  (setf  (slot-value destination-set 'elements) (delete element (slot-value destination-set 'elements)))
+  destination-set)
+
+(defmethod contains               ((set list-set) element)
+  (not (not (member element (slot-value set 'elements)))))
+
+(defmethod cardinal               ((set list-set))
+  (length  (slot-value set 'elements)))
+
+(defmethod select               ((set list-set))
+  (if (slot-value set 'elements)
+      (first (slot-value set 'elements))
+      (values)))
+
+(defmethod mapelements           (result-type mapper (set list-set))
+  (collecting-result (collect result-type)
+    (map nil
+         (lambda (element)
+           (collect (funcall mapper element)))
+         (slot-value set 'elements))))
+
+(defmethod make-collector        ((result-type (eql 'list-set)))
+  (declare (ignorable result-type))
+  (lambda (&optional set (element nil add-element-p))
+        (progn
+          (pushnew element (slot-value set 'elements))
+          set)
+        (make-instance 'list-set))))
+
+(defmethod minimum               ((set list-set))
+  (when (every (function realp) (slot-value set 'elements))
+    (reduce (function min) (slot-value set 'elements))))
+
+(defmethod maximum               ((set list-set))
+  (when (every (function realp) (slot-value set 'elements))
+    (reduce (function max) (slot-value set 'elements))))
+
+
+;;;-----------------------------------------------------------------------
+;;; TESTS
+;;;-----------------------------------------------------------------------
+
+(defun test-sets (test-class)
+  (list '() '(1) '(1 2 3)
+        '#() '#(1) '#(1 2 3)
+        (copy test-class '()) (copy test-class '(1)) (copy test-class '(1 2 3))))
+
+(define-test test/all/nil ()
+  (loop
+    :for seq :in (test-sets 'list-set)
+    :do
+    (test eql (mapelements nil (function identity) seq) nil)
+    (test set-equal (let ((result '()))
+                      (mapelements nil (lambda (element) (push element result)) seq)
+                      result)
+          seq)))
+
+(define-test test/mapelements (test-class)
+  (loop
+    :for set :in (test-sets test-class)
+    :do (loop
+          :for class :in (list 'list 'vector test-class)
+          :do (test set-equal (mapelements class (function identity) set)
+                    (ecase (cardinal set)
+                      (0 '())
+                      (1 '(1))
+                      (3 '(1 2 3)))))))
+
+(define-test test/copy (test-class)
+  (loop
+    :for (expected type original)
+    :in (list (list nil        'nil       '(1 2 3 4))
+              (list '(1 2 3 4) 'list      '(1 2 3 4))
+              (list '(1 2 3 4) 'vector    '(1 2 3 4))
+              (list '(1 2 3 4) test-class '(1 2 3 4)))
+    :do
+    (test set-equal               (copy type original)  expected (type original))
+    (test set-equal (copy 'list   (copy type original)) expected (type original))
+    (test set-equal (copy 'vector (copy type original)) expected (type original))))
+
+
+(define-test test/is-subseq (test-class1 test-class2)
+  (flet ((test-set1 (&rest elements)
+           (copy test-class1 elements))
+         (test-set2 (&rest elements)
+           (copy test-class2 elements)))
+    (assert-true (is-subset (test-set1)
+                            (test-set2)))
+    (assert-true (is-subset (test-set1 1)
+                            (test-set2 1)))
+    (assert-true (is-subset (test-set1 1 2 3)
+                            (test-set2 1 2 3)))
+    (assert-true (is-subset (test-set1 1 2 3  11 12 13)
+                            (test-set2 11 12 13 1 2 3)))
+    (assert-true (is-subset (test-set1)
+                            (test-set2 1)))
+    (assert-true (not (is-subset (test-set1 1)
+                                 (test-set2))))
+    (assert-true (not (is-subset (test-set1 1)
+                                 (test-set2 2))))
+    (assert-true (is-subset (test-set1 1 2 3)
+                            (test-set2 1 2 3 4)))
+    (assert-true (not (is-subset (test-set1 1 2 3 4)
+                                 (test-set2 1 2 3))))))
+
+
+(define-test test/set-equal (test-class)
+  (flet ((test-set (&rest elements)
+           (copy test-class elements)))
+    (assert-true (set-equal (test-set)
+                            (test-set)))
+    (assert-true (set-equal (test-set 1)
+                            (test-set 1)))
+    (assert-true (set-equal (test-set 1 2 3)
+                            (test-set 1 2 3)))
+    (assert-true (set-equal (test-set 1 2 3  11 12 13)
+                            (test-set 11 12 13 1 2 3)))
+    (assert-true (not (set-equal (test-set)
+                                 (test-set 1))))
+    (assert-true (not (set-equal (test-set 1)
+                                 (test-set))))
+    (assert-true (not (set-equal (test-set 1)
+                                 (test-set 2))))
+    (assert-true (not (set-equal (test-set 1 2 3)
+                                 (test-set 1 2 3 4))))
+    (assert-true (not (set-equal (test-set 1 2 3 4)
+                                 (test-set 1 2 3))))))
+
+
+(define-test test/union (operator test-class)
+  (flet ((test-set (&rest elements)
+           (copy test-class elements))
+         (test set-equal (funcall operator
+                                  (test-set 1 2 3 7 8 10 11 12)
+                                  (test-set 1 2 3 7 8 10 11 12))
+               (test-set 1 2 3 7 8 10 11 12))
+
+         (test set-equal (funcall operator
+                                  (test-set)
+                                  (test-set 1 2 3 7 8 10 11 12))
+               (test-set 1 2 3 7 8 10 11 12))
+
+         (test set-equal (funcall operator
+                                  (test-set 1 2 3 7 8 10 11 12)
+                                  (test-set))
+               (test-set 1 2 3 7 8 10 11 12))
+
+         (test set-equal (funcall operator
+                                  (test-set 1 2 3 7 8 10 11 12)
+                                  (test-set 0 4 5 6 9 10))
+               (test-set 0 1 2 3 4 5 6 7 8 9 10 11 12))
+
+         (test set-equal (funcall operator
+                                  (test-set 10 11 12)
+                                  (test-set 1 2 3 7 8))
+               (test-set 1 2 3 7 8 10 11 12))
+
+         (test set-equal (funcall operator
+                                  (test-set 1 2 3 7 8)
+                                  (test-set 10 11 12))
+               (test-set 1 2 3 7 8 10 11 12))
+
+         (test set-equal (funcall operator
+                                  (test-set 1 2 3 5 6 7)
+                                  (test-set 3 4 5 7 8 9  12 13))
+               (test-set 1 2 3 4 5 6 7 8 9 12 13))
+
+         (test set-equal (funcall operator
+                                  (test-set 1 2 3 5 6 7  12 13)
+                                  (test-set 3 4 5 7 8 9))
+               (test-set 1 2 3 4 5 6 7 8 9 12 13))
+
+         (test set-equal (funcall operator
+                                  (test-set 1 2 3  11 12 13)
+                                  (test-set 3 4 5  13 14 15))
+               (test-set 1 2 3 4 5 11 12 13 14 15))
+
+         (test set-equal (funcall operator
+                                  (test-set 3 4 5  13 14 15)
+                                  (test-set 1 2 3  11 12 13))
+               (test-set 1 2 3 4 5 11 12 13 14 15)))))
+
+
+(define-test test/intersection (operator test-class)
+  (flet ((test-set (&rest elements)
+           (copy test-class elements)))
+    (test set-equal (funcall operator
+                             (test-set 1 2 3 7 8 10 11 12)
+                             (test-set 1 2 3 7 8 10 11 12))
+          (test-set 1 2 3 7 8 10 11 12))
+
+    (test set-equal (funcall operator
+                             (test-set)
+                             (test-set 1 2 3 7 8 10 11 12))
+          (test-set))
+
+    (test set-equal (funcall operator
+                             (test-set 1 2 3 7 8 10 11 12)
+                             (test-set))
+          (test-set))
+
+    (test set-equal (funcall operator
+                             (test-set 1 2 3 7 8 10 11 12)
+                             (test-set 0 4 5 6 9 10))
+          (test-set 10))
+
+    (test set-equal (funcall operator
+                             (test-set 10 11 12)
+                             (test-set 1 2 3 7 8))
+          (test-set))
+
+    (test set-equal (funcall operator
+                             (test-set 1 2 3 7 8)
+                             (test-set 10 11 12))
+          (test-set))
+
+    (test set-equal (funcall operator
+                             (test-set 1 2 3 5 6 7)
+                             (test-set 3 4 5 7 8 9  12 13))
+          (test-set 3 5 7))
+
+    (test set-equal (funcall operator
+                             (test-set 1 2 3 5 6 7  12 13)
+                             (test-set 3 4 5 7 8 9))
+          (test-set 3 5 7))
+
+    (test set-equal (funcall operator
+                             (test-set 1 2 3  11 12 13)
+                             (test-set 3 4 5  13 14 15))
+          (test-set 3 13))
+
+    (test set-equal (funcall operator
+                             (test-set 3 4 5  13 14 15)
+                             (test-set 1 2 3  11 12 13))
+          (test-set 3 13))))
+
+
+
+(define-test test/all/sequence (test-class)
+  "All the tests working on LIST or VECTOR as sets."
+  (test/is-subseq test-class test-class)
+  (test/set-equal test-class)
+  (test/copy        test-class)
+  (test/mapelements test-class))
+
+(define-test test/all/class (test-class)
+  "All the tests working on set classes."
+  (test/all/sequence test-class)
+  (test/is-subseq test-class 'list)
+  (test/is-subseq test-class 'vector)
+  (test/is-subseq 'list   test-class)
+  (test/is-subseq 'vector test-class)
+  (test/union (function merge) test-class)
+  (test/union (curry (function union) test-class) test-class)
+  (test/union (curry (function union) 'vector) test-class)
+  (test/intersection (function intersect) test-class)
+  (test/intersection (curry (function intersection) test-class) test-class)
+  (test/intersection (curry (function intersection) 'vector) test-class))
+
+(define-test test/all ()
+  "All the set tests."
+  (test/all/nil)
+  (test/all/sequence 'list)
+  (test/all/sequence 'vector)
+  (test/all/class    'list-set))
+
+(test/all)
+
+;;;; THE END ;;;;
diff --git a/common-lisp/cesarum/simple-test.lisp b/common-lisp/cesarum/simple-test.lisp
new file mode 100644
index 0000000..ced2f22
--- /dev/null
+++ b/common-lisp/cesarum/simple-test.lisp
@@ -0,0 +1,303 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               simple-test.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Defines a simple test tool.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2010-12-14 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2010 - 2012
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
+  (:use "COMMON-LISP")
+  (:export "*DEBUG-ON-ERROR*" "WITH-DEBUGGER-ON-ERROR"
+           "DEFINE-TEST" "TEST" "ASSERT-TRUE" "EXPECT-CONDITION"
+
+           "*VERBOSE-TALLY*" "*VERBOSE-PROGRESS*")
+  (:documentation "
+This package defines a simple test tool.
+
+
+    AGPL3
+
+    Copyright Pascal J. Bourguignon 2010 - 2012
+
+    This program is free software: you can redistribute it and/or modify
+    the Free Software Foundation, either version 3 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU Affero General Public License for more details.
+
+    You should have received a copy of the GNU Affero General Public License
+    along with this program.
+"))
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST")
+
+
+(defvar *debug-on-error*          nil
+  "Whether an error in a test should go to the debugger.")
+(defvar *success-count*           0
+  "The total number of successful tests.")
+(defvar *failure-count*           0
+  "The total number of failed tests.")
+
+(defvar *verbose-tally* t
+  "Whether to print the number of successful, failed and performed tests.")
+(defvar *verbose-progress* nil
+  "Whether to display dots or exclamation points while testing.")
+
+(defvar *test-output* *standard-output*)
+
+;; Private:
+(defvar *last-success-p*          nil)
+(defvar *current-test-name*       nil)
+(defvar *current-test-parameters* nil)
+(defvar *current-test-printed-p*  nil)
+(defvar *report-string*           "")
+(defparameter *cr*                #\return)
+
+
+(defun progress-start ()
+  (setf *success-count*  0
+        *failure-count*  0
+        *last-success-p* nil
+        *report-string*  (make-array 8
+                                     :element-type 'character
+                                     :fill-pointer 0))
+  (values))
+
+
+(defun verbose (default)
+  (and default
+           (and (find-package "ASDF")
+                (find-symbol "*ASDF-VERBOSE*" "ASDF")
+                (symbol-value (find-symbol "*ASDF-VERBOSE*" "ASDF")))
+           (and (find-package "QUICKLISP")
+
+
+(defun progress-report (new-last-succcess-p)
+  (setf *last-success-p* new-last-succcess-p)
+  (when (verbose *verbose-progress*)
+    (if *last-success-p*
+        (format *test-output* "~A" (aref *report-string* (1- (length *report-string*))))
+        (format *test-output* "~&~A" *report-string*))
+    (finish-output *test-output*))
+  (values))
+
+
+(defun progress-success ()
+  (incf *success-count*)
+  (vector-push-extend #\. *report-string*)
+  (progress-report t))
+
+
+(defun current-test-identification (&optional max-length)
+  (let ((*print-circle* nil))
+   (if max-length
+       (let* ((items (mapcar (lambda (parameter)
+                               (let ((label (let ((*package* (if (and (symbolp parameter)
+                                                                      (symbol-package parameter))
+                                                                 (symbol-package parameter)
+                                                                 *package*)))
+                                              (format nil "~S" parameter))))
+                                 (list (length label) label)))
+                             (cons *current-test-name* *current-test-parameters*)))
+              (idlength (+ 1 (length items) (reduce (function +) items :key (function first))))
+              (candidates (sort (butlast (loop
+                                           :for cell :on items
+                                           :collect cell))
+                                (function >)
+         (loop
+           :until (<= idlength max-length)
+           :do (progn
+                 (decf idlength (1- (caadar candidates)))
+                 (setf (car (cdadar candidates)) "…")
+                 (pop candidates))
+           :finally (return (format nil "(~{~A~^ ~})" (mapcar (function second) items)))))
+       (format nil "(~{~S~^ ~})" (cons *current-test-name* *current-test-parameters*)))))
+
+;; (let ((*current-test-name* 'hello-world)
+;;       (*current-test-parameters* '((1 2 3 4) "howdy doo dabadaboo" #(a b c d e f))))
+;;   (current-test-identification  nil))
+
+
+
+(defun progress-failure-message (expression message &rest arguments)
+  (incf *failure-count*)
+  (vector-push-extend #\! *report-string*)
+  (unless *current-test-printed-p*
+    (setf  *current-test-printed-p* t)
+    (format *test-output* "~&~A" (current-test-identification)))
+  (format *test-output* "~&Failure:     expression: ~S~@
+             ~&~?~%"
+          expression message arguments)
+  (progress-report nil))
+
+
+(defun progress-failure (compare expression expected-result result &optional places)
+  (progress-failure-message expression "~&           evaluates to: ~S~@
+                                        ~&           which is not  ~A~@
+                                        ~& to the expected result: ~S~@
+                                        ~{~&~23A: ~S~}"
+                            result compare expected-result places))
+
+
+(defun progress-tally (success-count failure-count)
+  (when (verbose *verbose-tally*)
+    (let ((name-max-length 40))
+     (flet ((genline (name)
+              (format nil "~VA~3D ~9A~3D ~8A~5D ~A"
+                      name-max-length name
+                      success-count (format nil "success~[es~;~:;es~]," success-count)
+                      failure-count (format nil "failure~P," failure-count)
+                      (+ success-count failure-count)
+                      (format nil "test~P." (+ success-count failure-count)))))
+       (format *test-output* "~&~A~%"
+               (genline  (current-test-identification name-max-length)))
+       (finish-output *test-output*)
+       ;; (let* ((test-name (current-test-identification name-max-length))
+       ;;        (data (genline ""))
+       ;;        (nlen (length test-name)))
+       ;;   (format *test-output* "~&~A~%"
+       ;;           (if (and (< nlen (+ name-max-length 4)) (char= #\space (aref data nlen)))
+       ;;               (progn
+       ;;                 (replace data test-name)
+       ;;                 data)
+       ;;               (genline (concatenate 'string (subseq test-name 0 43) "…"))))
+       ;;   (finish-output *test-output*))
+       )))
+  (values))
+
+
+(defmacro assert-true (expression)
+  "Evaluates a test EXPRESSION and check it returns true.
+EXAMPLE:  (assert-true (= 2 (+ 1 1))))
+"
+  (let ((vresult   (gensym "RESULT-")))
+    `(let ((,vresult   (if *debug-on-error*
+                           (handler-bind
+                               ((error (function invoke-debugger)))
+                             ,expression)
+                           (handler-case
+                               ,expression
+                             (error (err) (list 'error (princ-to-string err)))))))
+       (if ,vresult
+           (progress-success)
+           (progress-failure 'equivalent ',expression 't ,vresult)))))
+
+
+(defmacro expect-condition (condition-class expression)
+  "Evaluates a test EXPRESSION and check that it signals a condition of the specified CONDITION-CLASS.
+EXAMPLE:  (expect-condition division-by-zero (/ 1 0))
+"
+  (let ((body (gensym)))
+    `(flet ((,body ()
+                   ,expression
+                   (progress-failure-message ',expression
+                                             "Didn't signal the expected ~S condition."
+                                             ',condition-class)))
+       (if *debug-on-error*
+           (block expect
+             (handler-bind
+                 ((,condition-class (lambda (condition)
+                                      (declare (ignore condition))
+                                      (progress-success)
+                                      (return-from expect)))
+                  (t (function invoke-debugger)))
+               (,body)))
+           (handler-case
+               (,body)
+             (,condition-class ()
+               (progress-success))
+             (t (condition)
+               (progress-failure-message ',expression
+                                         "Signaled an unexpected ~S condition instead of ~S."
+                                         condition
+                                         ',condition-class)))))))
+
+
+
+(defmacro test (compare expression expected &optional places)
+  "Evaluates a test EXPRESSION and compare the result with EXPECTED (evaluated) using the COMPARE operator.
+EXAMPLE:  (test equal (list 1 2 3) '(1 2 3))
+"
+  (let ((vresult   (gensym "RESULT-"))
+        (vexpected (gensym "EXPECTED-")))
+    `(let ((,vresult   (if *debug-on-error*
+                           (handler-bind
+                               ((error (function invoke-debugger)))
+                             ,expression)
+                           (handler-case
+                               ,expression
+                             (error (err) (list 'error (princ-to-string err))))))
+           (,vexpected ,expected))
+       (if (,compare ,vresult ,vexpected)
+           (progress-success)
+           (progress-failure ',compare ',expression ,vexpected ,vresult
+                             (list ,@(mapcan (lambda (place) `(',place ,place)) places)))))))
+
+
+(defmacro define-test (name parameters &body body)
+  "Like DEFUN, but wraps the body in test reporting boilerplate."
+  (let ((mandatory (loop
+                     :for param :in parameters
+                     :while (symbolp param)
+                     :collect param)))
+    `(defun ,name ,parameters
+       (multiple-value-bind (successes failures)
+           (let ((*success-count* 0)
+                 (*failure-count* 0)
+                 (*current-test-name*        ',name)
+                 (*current-test-parameters* (list ,@mandatory))
+                 (*current-test-printed-p*  nil))
+             (progress-start)
+             (locally ,@body)
+             (progress-tally *success-count* *failure-count*)
+             (values *success-count* *failure-count*))
+         (incf *success-count* successes)
+         (incf *failure-count* failures)
+         (if (zerop failures)
+             :success
+             :failure)))))
+
+(defmacro with-debugger-on-error (&body body)
+  `(let ((*debug-on-error* t))
+     ,@body))
+
+;;;; THE END ;;;;
diff --git a/common-lisp/cesarum/utility.lisp b/common-lisp/cesarum/utility.lisp
index 02e1fbd..cba4ac7 100644
--- a/common-lisp/cesarum/utility.lisp
+++ b/common-lisp/cesarum/utility.lisp
@@ -53,7 +53,8 @@
"COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM" )
(:export
;; 3 - EVALUATION AND COMPILATION
-   "WITH-GENSYMS" "WSIOSBP" "COMPOSE" "COMPOSE-AND-CALL"
+   "WITH-GENSYMS" "WSIOSBP"
+   "CURRY" "COMPOSE" "COMPOSE-AND-CALL"
"DEFINE-IF-UNDEFINED"  "INCLUDE" "FUNCTIONAL-PIPE"
"FIRST-ARG" "SECOND-ARG" "THIRD-ARG" "FOURTH-ARG" "FIFTH-ARG"
"SIXTH-ARG" "SEVENTH-ARG" "EIGHTH-ARG" "NINTH-ARG" "TENTH-ARG"
@@ -88,7 +89,7 @@
"DICHOTOMY"
"TRACING" "TRACING-LET" "TRACING-LET*" "TRACING-LABELS"
;;
-   "XOR" "EQUIV" "IMPLY" "SET-EQUAL"
+   "XOR" "EQUIV" "IMPLY" ;; "SET-EQUAL"
)
(:documentation
"
@@ -178,6 +179,18 @@ The *PACKAGE* is kept bound to the current package.
(define-argument-selector tenth-arg   10)

+(defun curry (function &rest left-arguments)
+  (lambda (&rest right-arguments)
+    (apply function (append left-arguments right-arguments))))
+
+;; (defmacro curry (function &rest left-arguments)
+;;   (let ((parameters (mapcar (lambda (arg) (gensym)) left-arguments))
+;;         (right-arguments (gensym)))
+;;     `(let ,(mapcar (function list) parameters left-arguments)
+;;        (lambda (&rest ,right-arguments)
+;;          (apply (function ,function) ,@parameters ,right-arguments)))))
+
+
(defun compose-sexp (functions var)
(if (null functions)
@@ -286,13 +299,24 @@ Return the results of the last form.
(defmacro defenum (name-and-options &rest constants)
"
Define an named enumeration type, a set of constants with integer
-values, and a lable function to produce the name of the constants from
+values, and a label function to produce the name of the constants from
the numerical value.
+
+NAME-AND-OPTIONS:
+
+            The name of the enum type, or a list containing the name
+            of the enum type and options (no option defined so far).
+            The label function defined is named <enum-type-name>-LABEL
+
+CONSTANTS:  The first element of CONSTANTS may be an optional docstring.
+            Each constant is either a symbol naming the constant of the enum,
+            (the value is then the successor of the previous value),
+            or a list containing the constant name and the constant value.
"
(let ((name (if (consp name-and-options)
(first name-and-options)
name-and-options)))
-    (when (stringp (first constants))
+    (when (stringp (first constants)) ; docstring
(pop constants))
;; define a ({NAME}-LABEL value) function.
@@ -300,33 +324,33 @@ the numerical value.
,(format nil "Produce the name of the constant having the given VALUE.")
(case value
,@(loop
-                for cname in constants
-                with val = -1
-                do (if (consp cname)
+               :with val = -1
+               :for cname :in constants
+               :do (if (consp cname)
(setf val (second cname))
(incf val))
-                collect `((,val) ',(if (consp cname)
+               :collect `((,val) ',(if (consp cname)
(first cname)
cname)))
(otherwise (format nil "#<~A:~D>" ',name value))))
;; define the constants.
,@(loop
-            for cname in constants
-            with val = -1
-            do (when (consp cname)
+           :with val = -1
+           :for cname :in constants
+           :do (when (consp cname)
(setf val (1- (second cname)) cname (first cname)))
-            collect `(defconstant ,cname ,(incf val)
+           :collect `(defconstant ,cname ,(incf val)
,(format nil "~A enumeration value." name)))
;; define the type.
(deftype ,name ()
"An enumeration type." ;; TODO: get a docstring from the parameters.
'(member ,@(loop
-                       for cname in constants
-                       with val = -1
-                       do (if (consp cname)
+                      :with val = -1
+                      :for cname :in constants
+                      :do (if (consp cname)
(setf val (second cname))
(incf val))
-                       collect val))))))
+                      :collect val))))))

(defun op-type-of (symbol &optional env)
@@ -1044,28 +1068,30 @@ POST:	(<= start index end)
| a[max] < x        |   FALSE  |  max  |  greater |      0         |
+-------------------+----------+-------+----------+----------------+
"
-  (let* ((curmin start)
-         (curmax end)
-         (index    (truncate (+ curmin curmax) 2))
-         (order  (funcall compare value (funcall key (aref vector index)))) )
-    (loop :while (and (/= 0 order) (/= curmin index)) :do
-       ;; (FORMAT T "~&min=~S  cur=~S  max=~S   key=~S <~S> [cur]=~S ~%" CURMIN INDEX CURMAX VALUE (FUNCALL COMPARE VALUE (FUNCALL KEY (AREF VECTOR INDEX))) (AREF VECTOR INDEX))
-       (if (< order 0)
-           (setf curmax index)
-           (setf curmin index))
-       (setf index (truncate (+ curmin curmax) 2))
-       (setf order  (funcall compare value (funcall key (aref vector index)))))
-    (when (and (< start index) (< order 0))
-      (setf order 1)
-      (decf index))
-    (assert
-     (or (< (funcall compare value (funcall key (aref vector index))) 0)
-         (and (> (funcall compare value (funcall key (aref vector index))) 0)
-              (or (>= (1+ index) end)
-                  (< (funcall compare value
-                              (funcall key (aref vector (1+  index)))) 0)))
-         (= (funcall compare value (funcall key (aref vector index))) 0)))
-    (values (= order 0) index order)))
+  (if (zerop (length vector))
+      (values nil 0 -1)
+      (let* ((curmin start)
+             (curmax end)
+             (index  (truncate (+ curmin curmax) 2))
+             (order  (funcall compare value (funcall key (aref vector index)))) )
+        (loop :while (and (/= 0 order) (/= curmin index)) :do
+          ;; (FORMAT T "~&min=~S  cur=~S  max=~S   key=~S <~S> [cur]=~S ~%" CURMIN INDEX CURMAX VALUE (FUNCALL COMPARE VALUE (FUNCALL KEY (AREF VECTOR INDEX))) (AREF VECTOR INDEX))
+          (if (< order 0)
+              (setf curmax index)
+              (setf curmin index))
+          (setf index (truncate (+ curmin curmax) 2))
+          (setf order  (funcall compare value (funcall key (aref vector index)))))
+        (when (and (< start index) (< order 0))
+          (setf order 1)
+          (decf index))
+        (assert
+         (or (< (funcall compare value (funcall key (aref vector index))) 0)
+             (and (> (funcall compare value (funcall key (aref vector index))) 0)
+                  (or (>= (1+ index) end)
+                      (< (funcall compare value
+                                  (funcall key (aref vector (1+  index)))) 0)))
+             (= (funcall compare value (funcall key (aref vector index))) 0)))
+        (values (= order 0) index order))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1415,9 +1441,9 @@ DO:       Evaluate the expression, which must be a real,
"Return P ⇒ Q"
(or (not p) q))

-(defun set-equal (a b)
-  "Return A ⊂ B ∧ A ⊃ B"
-  (and (subsetp a b) (subsetp b a)))
+;; (defun set-equal (a b)
+;;   "Return A ⊂ B ∧ A ⊃ B"
+;;   (and (subsetp a b) (subsetp b a)))

;;;; THE END ;;;;```
ViewGit