Use generic functions for most of the API.

Pascal J. Bourguignon [2015-10-31 09:28]
Use generic functions for most of the API.
Filename
common-lisp/cesarum/brelation.lisp
common-lisp/cesarum/bset.lisp
diff --git a/common-lisp/cesarum/brelation.lisp b/common-lisp/cesarum/brelation.lisp
index 9c33299..67a1caa 100644
--- a/common-lisp/cesarum/brelation.lisp
+++ b/common-lisp/cesarum/brelation.lisp
@@ -44,22 +44,20 @@
 ;;;;    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")
-(declaim (declaration also-use-packages))
-(declaim (also-use-packages "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BSET"))
 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BRELATION"
-  (:use "COMMON-LISP")
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BSET")
+  (:shadow "COMPLEMENT" "INTERSECTION" "UNION" "SUBSETP")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
+                "VECTOR-INIT" "FOR" "UNTIL")
   (:export "PROJECT-2" "PROJECT-1" "WRITE-BRELATION" "READ-BRELATION"
            "FOR-ALL-DO" "EXISTS-1" "EXISTS" "FOR-ALL" "EXTRACT" "SELECT" "CARDINAL"
-           "IS-EMPTY" "IS-NOT-EQUAL" "IS-EQUAL" "IS-STRICT-SUBSET" "IS-SUBSET"
+           "EMPTYP" "IS-NOT-EQUAL" "IS-EQUAL" "IS-STRICT-SUBSET" "IS-SUBSET"
            "COMPLEMENT" "SYM-DIFF" "INTERSECTION" "DIFFERENCE" "UNION" "ASSIGN"
            "ASSIGN-ELEMENT" "ASSIGN-EMPTY" "CLOSURE" "GET-CYCLICS" "IS-CYCLIC"
            "HAS-REFLEXIVE" "IS-EQUIVALENCE" "IS-TRANSITIVE" "IS-SYMMETRIC"
            "IS-REFLEXIVE" "IS-TRANSITIVE-1" "IS-REFLEXIVE-1" "IS-RELATED" "IS-ELEMENT"
            "EXCLUDE" "INCLUDE" "MAKE-BRELATION" "BRELATION")
-  (:shadow "COMPLEMENT" "INTERSECTION" "UNION")
-  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "VECTOR-INIT" "FOR")
   (:documentation
    "

@@ -75,7 +73,7 @@ License:

     AGPL3

-    Copyright Pascal J. Bourguignon 2004 - 2012
+    Copyright Pascal J. Bourguignon 2004 - 2015

     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU Affero General Public License as published by
@@ -94,15 +92,15 @@ License:
 "))
 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BRELATION")

-
+(deftype element () '(integer 0))

 (defstruct (brelation (:constructor %make-brelation))
   "The Binary Relation Class."
-  (adjsets (make-array '(0) :element-type 'com.informatimago.common-lisp.cesarum.bset:bset
-                       :initial-element (com.informatimago.common-lisp.cesarum.bset:make-bset 0))
-           :type (array com.informatimago.common-lisp.cesarum.bset:bset (*)))
-  (size-1 0 :type (integer 0))
-  (size-2 0 :type (integer 0)))
+  (adjsets (make-array '(0) :element-type 'bset
+                            :initial-element (make-bset 0))
+           :type (array bset (*)))
+  (size-1 0 :type element)
+  (size-2 0 :type element))



@@ -110,14 +108,14 @@ License:
   "
 RETURN: A new BRELATION between sets of sizes SIZE-1 and SIZE-2.
 "
-  (declare (type (integer 0) size-1 size-2))
+  (declare (type element size-1 size-2))
   (%make-brelation
    :adjsets (vector-init (make-array (list (1+ size-1))
-                                     :element-type 'com.informatimago.common-lisp.cesarum.bset:bset
-                                     :initial-element (com.informatimago.common-lisp.cesarum.bset:make-bset 0))
+                                     :element-type 'bset
+                                     :initial-element (make-bset 0))
                          (lambda (index)
                            (declare (ignore index))
-                           (com.informatimago.common-lisp.cesarum.bset:make-bset size-2)))
+                           (make-bset size-2)))
    :size-1 size-1
    :size-2 size-2))

@@ -133,358 +131,356 @@ NOTE:   This short circuits the evaluation of Q if P is false.
   `(aref (brelation-adjsets ,rel) ,i))

 (defmacro related (rel e1 e2)
-  `(com.informatimago.common-lisp.cesarum.bset:is-element ,e2 (adjref ,rel ,e1)))
-
-
-(defun include (rel e1 e2)
+  `(is-element ,e2 (adjref ,rel ,e1)))
+
+
+(deftype arc () 'cons)
+(defun arc (e1 e2) (cons e1 e2))
+(defun arc-from (arc) (car arc))
+(defun arc-to   (arc) (cdr arc))
+(defmacro with-arc (((e1 e2) arc) &body body)
+  (let ((varc (gensym)))
+    `(let ((,varc ,arc))
+       (check-type ,varc arc)
+       (let ((,e1 (arc-from ,varc))
+             (,e2 (arc-to   ,varc)))
+         (check-type ,e1 element)
+         (check-type ,e2 element)
+         ,@body))))
+
+(defmethod include ((rel brelation) arc)
   "
 DO:     Adds (E1 E2) to the relation REL.
 POST:   REL(E1,E2)
 "
-  (declare (type (integer 0) e1 e2))
-  (com.informatimago.common-lisp.cesarum.bset:include (adjref rel e1) e2)
+  (with-arc ((e1 e2) arc)
+    (include (adjref rel e1) e2))
   rel)

-
-(defun exclude (rel e1 e2)
+(defmethod exclude ((rel brelation) arc)
   "
 DO:     Remove (E1 E2) from the relation REL.
 POST:   ¬ REL(E1,E2)
 "
-  (declare (type (integer 0) e1 e2))
-  (com.informatimago.common-lisp.cesarum.bset:exclude (adjref rel e1) e2)
+  (with-arc ((e1 e2) arc)
+    (exclude (adjref rel e1) e2))
   rel)

-
-(defun is-element (e1 e2 rel)
+(defmethod is-element (arc (rel brelation))
   "
 RETURN: Whether REL(E1,E2).
 "
-  (declare (type (integer 0) e1 e2))
-  (related rel e1 e2))
-
+  (with-arc ((e1 e2) arc)
+    (related rel e1 e2)))

-(defun is-related (e1 e2 rel)
+(defgeneric is-related (e1 e2 rel))
+(defmethod is-related (e1 e2 (rel brelation))
   "
 RETURN: Whether REL(E1,E2).
 "
-  (declare (type (integer 0) e1 e2))
   (related rel e1 e2))

-
-(defun is-reflexive-1 (e1 rel)
+(defgeneric is-reflexive-1 (e1 rel))
+(defmethod is-reflexive-1 (e1 (rel brelation))
   "
 RETURN: Whether REL(E1,E1)
 "
-  (declare (type (integer 0) e1))
+  (check-type e1 element)
   (related rel e1 e1))

-
-(defun is-symmetric-1 (e1 e2 rel)
-    "
+(defgeneric is-symmetric-1 (e1 e2 rel))
+(defmethod is-symmetric-1 (e1 e2 (rel brelation))
+  "
 RETURN: Whether REL(E1,E2) ∧ REL(E2,E1)
 "
-  (declare (type (integer 0) e1 e2))
+  (check-type e1 element)
+  (check-type e2 element)
   (imply (related rel e1 e2) (related rel e2 e1)))

-
-(defun is-transitive-1 (e1 e2 e3 rel)
-      "
+(defgeneric is-transitive-1 (e1 e2 e3 rel))
+(defmethod is-transitive-1 (e1 e2 e3 (rel brelation))
+  "
 RETURN: Whether (REL(E1,E2) ∧ REL(E2,E3)) ⇒ REL(E1,E3)
 NOTE:   Tests the transitivity of the relation REL only on the
         elements E1, E2, and E3.  This doesn't mean the relation REL
         is transitive (but it's a necessary condition).
 "
-  (declare (type (integer 0) e1 e2 e3))
+  (check-type e1 element)
+  (check-type e2 element)
+  (check-type e3 element)
   (imply (and (related rel e1 e2) (related rel e2 e3)) (related rel e1 e3)))


-(defun is-reflexive (rel)
+(defgeneric is-reflexive (rel))
+(defmethod is-reflexive ((rel brelation))
   "
 RETURN: Whether the relation REL is reflexive. Ie. ∀i∈[0,SIZE1-1], REL(i,i)
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (related rel i i) (return-from is-reflexive nil)))
+    (unless (related rel i i) (return-from is-reflexive nil)))
   t)

-
-(defun is-symmetric (rel)
+(defgeneric is-symmetric (rel))
+(defmethod is-symmetric ((rel brelation))
   "
 RETURN: Whether the relation REL is symetric. Ie. ∀(i,j)∈[0,SIZE1-1]², REL(i,j) ⇒ REL(j,i)
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:for-all (adjref rel i)
-                                                                   (lambda (j) (related rel j i)))
-         (return-from is-symmetric nil)))
+    (unless (for-all (adjref rel i)
+                     (lambda (j) (related rel j i)))
+      (return-from is-symmetric nil)))
   t)


-(defun is-transitive (rel)
-   "
+(defgeneric is-transitive (rel))
+(defmethod is-transitive ((rel brelation))
+  "
 RETURN: Whether the relation REL is transitive. Ie. ∀(i,j,k)∈[0,SIZE1-1]³, REL(i,j) ∧ REL(j,k) ⇒ REL(i,k)
 "
-   (let ((r (make-brelation (brelation-size-1 rel) (brelation-size-2 rel))))
+  (let ((r (make-brelation (brelation-size-1 rel) (brelation-size-2 rel))))
     (assign r rel)
     (closure r)
     (is-equal r rel) ))


-(defun is-equivalence (rel)
+(defgeneric is-equivalence (rel))
+(defmethod is-equivalence ((rel brelation))
   "
 RETURN: Whether REL is an equivalence relation. Ie. REL is reflexive, symetric and transitive.
 "
   (and (is-reflexive rel) (is-symmetric rel) (is-transitive rel)))


-(defun has-reflexive (rel)
+(defgeneric has-reflexive (rel))
+(defmethod has-reflexive ((rel brelation))
   "
 RETURN: ∃i∈[0,SIZE1-1], REL(i,i)
 "
   (for (i 0 (brelation-size-1 rel))
-       (when (related rel i i) (return-from has-reflexive t)))
+    (when (related rel i i) (return-from has-reflexive t)))
   nil)

-
-(defmacro until (condition &body body) `(do () (,condition) ,@body))
-
-
-(defun is-cyclic (rel)
+(defgeneric is-cyclic (rel))
+(defmethod is-cyclic ((rel brelation))
   "
 RETURN: Whether the relation REL is cyclic.
 "
-  (let ((with-pred    (com.informatimago.common-lisp.cesarum.bset:make-bset (brelation-size-1 rel)))
-        (without-pred (com.informatimago.common-lisp.cesarum.bset:make-bset (brelation-size-1 rel)))
+  (let ((with-pred    (make-bset (brelation-size-1 rel)))
+        (without-pred (make-bset (brelation-size-1 rel)))
         (pred-count   (make-array (list (1+ (brelation-size-1 rel)))
-                                  :element-type '(integer 0)
+                                  :element-type 'element
                                   :initial-element 0)))
     (for (i 0 (brelation-size-1 rel))
-      (com.informatimago.common-lisp.cesarum.bset:for-all-do (adjref rel i)
-                                                             (lambda (e) (incf (aref pred-count e)))))
+      (for-all-do (adjref rel i)
+                  (lambda (e) (incf (aref pred-count e)))))
     (for (i 0 (brelation-size-1 rel))
       (when (= 0 (aref pred-count i))
-        (com.informatimago.common-lisp.cesarum.bset:include without-pred i)))
-    (com.informatimago.common-lisp.cesarum.bset:complement with-pred)
-    (until (com.informatimago.common-lisp.cesarum.bset:is-empty without-pred)
-      (let ((i (com.informatimago.common-lisp.cesarum.bset:extract without-pred)))
-        (com.informatimago.common-lisp.cesarum.bset:exclude with-pred i)
-        (com.informatimago.common-lisp.cesarum.bset:for-all-do (adjref rel i)
-                                                               (lambda (e) (decf (aref pred-count e))
-                                                                 (when (= 0 (aref pred-count e))
-                                                                   (com.informatimago.common-lisp.cesarum.bset:include without-pred e))))))
-    (not (com.informatimago.common-lisp.cesarum.bset:is-empty with-pred))))
-
-
-
-(defun get-cyclics (rel bset)
+        (include without-pred i)))
+    (complement with-pred)
+    (until (emptyp without-pred)
+      (let ((i (extract without-pred)))
+        (exclude with-pred i)
+        (for-all-do (adjref rel i)
+                    (lambda (e) (decf (aref pred-count e))
+                      (when (= 0 (aref pred-count e))
+                        (include without-pred e))))))
+    (not (emptyp with-pred))))
+
+(defgeneric get-cyclics (rel bset))
+(defmethod get-cyclics ((rel brelation) (bset bset))
   "
 RETURN: The set of elements that are in cycles.
 "
   (let ((r (make-brelation (brelation-size-1 rel)(brelation-size-2 rel))))
     (assign r rel)
     (closure r)
-    (com.informatimago.common-lisp.cesarum.bset:assign-empty bset)
+    (assign-empty bset)
     (for (i 0 (brelation-size-1 rel))
-         (when (related r i i) (com.informatimago.common-lisp.cesarum.bset:include bset i))))
+      (when (related r i i) (include bset i))))
   bset)

-
-(defun assign-empty (rel)
+(defmethod assign-empty ((rel brelation))
   "
 POST:   REL is the empty relation.
 RETURN: REL
 "
   (for (i 0 (brelation-size-1 rel))
-       (com.informatimago.common-lisp.cesarum.bset:assign-empty (adjref rel i)))
+       (assign-empty (adjref rel i)))
   rel)

-
-(defun assign-element (rel e1 e2)
+(defmethod assign-element ((rel brelation) arc)
     "
 POST:   REL contains only (E1,E2).
 RETURN: REL
 "
-  (assign-empty rel)
-  (include rel e1 e2)
+  (with-arc ((e1 e2) arc)
+    (assign-empty rel)
+    (include rel (arc e1 e2)))
   rel)

-
-(defun assign (rel1 rel2)
+(defmethod assign ((rel1 brelation) (rel2 brelation))
   "
 POST:   REL1 is a copy of REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:assign-empty (adjref rel1 i))
-       (com.informatimago.common-lisp.cesarum.bset:assign-empty (adjref rel2 i)))
+       (assign-empty (adjref rel1 i))
+       (assign-empty (adjref rel2 i)))
   rel1)

-
-(defun closure (rel)
+(defmethod closure ((rel brelation))
     "
 POST:   REL is the transitive closure of the old REL.
 RETURN: REL
 "
   (for (j 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-empty (adjref rel j))
+       (unless (emptyp (adjref rel j))
          (for (i 0 (brelation-size-1 rel))
               (when (related rel i j)
-                (com.informatimago.common-lisp.cesarum.bset:union (adjref rel i)
+                (union (adjref rel i)
                             (adjref rel j))))))
   rel)

-
-(defun union (rel1 rel2)
+(defmethod union ((rel1 brelation) (rel2 brelation))
      "
 POST:   REL1 is the union of old REL1 and REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:union (adjref rel1 i) (adjref rel2 i)))
+       (union (adjref rel1 i) (adjref rel2 i)))
   rel1)

-
-(defun difference (rel1 rel2)
+(defmethod difference ((rel1 brelation) (rel2 brelation))
   "
 POST:   REL1 is the difference of old REL1 and REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:difference (adjref rel1 i) (adjref rel2 i)))
+       (difference (adjref rel1 i) (adjref rel2 i)))
   rel1)

-
-(defun intersection (rel1 rel2)
+(defmethod intersection ((rel1 brelation) (rel2 brelation))
     "
 POST:   REL1 is the intersection of old REL1 and REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:intersection (adjref rel1 i) (adjref rel2 i)))
+       (intersection (adjref rel1 i) (adjref rel2 i)))
   rel1)

-
-(defun sym-diff (rel1 rel2)
+(defmethod sym-diff ((rel1 brelation) (rel2 brelation))
   "
 POST:   REL1 is the symetric difference of old REL1 and REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:sym-diff (adjref rel1 i) (adjref rel2 i)))
+       (sym-diff (adjref rel1 i) (adjref rel2 i)))
   rel1)

-
-(defun complement (rel)
+(defmethod complement ((rel brelation))
   "
 POST:   REL is the complement of old REL.
 RETURN: REL
 "
   (for (i 0 (brelation-size-1 rel))
-       (com.informatimago.common-lisp.cesarum.bset:complement (adjref rel i)))
+       (complement (adjref rel i)))
   rel)

-
-(defun is-subset (rel1 rel2)
+(defmethod subsetp ((rel1 brelation) (rel2 brelation))
   "
 RETURN: Whether REL1 is a subset of REL2.
 "
   (for (i 0 (brelation-size-1 rel1))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-subset (adjref rel1 i) (adjref rel2 i))
-         (return-from is-subset nil)))
+       (unless (subsetp (adjref rel1 i) (adjref rel2 i))
+         (return-from subsetp nil)))
   t)

-
-(defun is-strict-subset (rel1 rel2)
+(defmethod strict-subsetp ((rel1 brelation) (rel2 brelation))
     "
 RETURN: Whether REL1 is a strict subset of REL2.
 "
   (and (is-subset rel1 rel2) (is-not-equal rel1 rel2)))

-
-(defun is-equal (rel1 rel2)
-      "
+(defmethod is-equal ((rel1 brelation) (rel2 brelation))
+  "
 RETURN: Whether REL1 is equal to REL2.
 "
   (for (i 0 (brelation-size-1 rel1))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-equal  (adjref rel1 i) (adjref rel2 i))
-         (return-from is-equal nil)))
+    (unless (is-equal  (adjref rel1 i) (adjref rel2 i))
+      (return-from is-equal nil)))
   t)

-
-(defun is-not-equal (rel1 rel2)
+(defmethod is-not-equal ((rel1 brelation) (rel2 brelation))
         "
 RETURN: Whether REL1 is not equal to REL2.
 "
   (not (is-equal rel1 rel2)))


-(defun is-empty (rel)
-          "
+(defmethod emptyp ((rel brelation))
+  "
 RETURN: Whether REL is empty.
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-empty  (adjref rel i))
-         (return-from is-empty  nil)))
+    (unless (emptyp (adjref rel i))
+      (return-from emptyp nil)))
   t)

-
-(defun cardinal (rel)
+(defmethod cardinal ((rel brelation))
   "
 RETURN: The number of couples in the relation REL.
 "
   (let ((n 0))
     (for (i 0 (brelation-size-1 rel))
-         (incf n (com.informatimago.common-lisp.cesarum.bset:cardinal (adjref rel i))))
+         (incf n (cardinal (adjref rel i))))
     n))

-
-(defun select (rel)
+(defmethod select ((rel brelation))
     "
 RETURN: (values i j) such as REL(i,j), or NIL if REL is empty.
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-empty (adjref rel i))
-         (return-from select (values i (com.informatimago.common-lisp.cesarum.bset:select (adjref rel i))))))
+       (unless (emptyp (adjref rel i))
+         (return-from select (values i (select (adjref rel i))))))
   nil)

-
-(defun extract (rel)
+(defmethod extract ((rel brelation))
   "
 DO:     Selects a couple in the relation REL, exclude it from REL, and return it.
-PRE:    (not (is-empty rel))
+PRE:    (not (emptyp rel))
 POST:   ¬REL(i,j)
 RETURN: (values i j) such as old REL(i,j), or NIL if REL is empty.
 "
   (multiple-value-bind (e1 e2) (select rel)
     (when e2
-      (exclude rel e1 e2)
+      (exclude rel (arc e1 e2))
       (values e1 e2))))


-(defun for-all (rel proc)
+(defmethod for-all ((rel brelation) proc)
   "
 DO:     Calls PROC on couples of the relation REL while it returns true.
 PROC:   A predicate of two elements.
 RETURN: Whether PROC returned true for all couples.
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:for-all (adjref rel i) (lambda (e) (funcall proc i e)))
+       (unless (for-all (adjref rel i) (lambda (e) (funcall proc i e)))
          (return-from for-all nil)))
   t)

-
-(defun exists (rel proc)
+(defmethod exists ((rel brelation) proc)
    "
 DO:     Calls PROC on  couples of the relation REL until it returns true.
 PROC:   A predicate of two elements.
 RETURN: Whether PROC returned true for at least one couple.
 "
   (for (i 0 (brelation-size-1 rel))
-       (when (com.informatimago.common-lisp.cesarum.bset:exists (adjref rel i) (lambda (e) (funcall proc i e)))
+       (when (exists (adjref rel i) (lambda (e) (funcall proc i e)))
          (return-from exists t)))
   nil)


-(defun exists-1 (rel proc)
+(defmethod exists-1 ((rel brelation) proc)
   "
 DO:     Calls PROC on each couples of the relation REL.
 PROC:   A predicate of two elements.
@@ -492,19 +488,19 @@ RETURN: Whether PROC returned true for exactly one couple.
 "
   (let ((n 0))
     (for (i 0 (brelation-size-1 rel))
-         (when (com.informatimago.common-lisp.cesarum.bset:exists (adjref rel i) (lambda (e) (funcall proc i e)))
+         (when (exists (adjref rel i) (lambda (e) (funcall proc i e)))
            (incf n)))
     (= n 1)))


-(defun for-all-do (rel proc)
+(defmethod for-all-do ((rel brelation) proc)
   "
 DO:     Calls PROC on each couple of the relation REL.
 PROC:   A function of two elements.
 RETURN: REL
 "
   (for (i 0 (brelation-size-1 rel))
-       (com.informatimago.common-lisp.cesarum.bset:for-all-do (adjref rel i) (lambda (e) (funcall proc i e))))
+       (for-all-do (adjref rel i) (lambda (e) (funcall proc i e))))
   rel)


@@ -523,13 +519,12 @@ NOTE:   The serialization format is that of a list of adjacency lists.
         ((char= (peek-char t stream nil (character ")")) (character ")"))
          (read-char stream))
       (let ((i (read stream)))
-
         (when (peek-char (character "(") stream nil nil)
           (read-char stream)
           (do ()
               ((char= (peek-char t stream nil (character ")")) (character ")"))
                (read-char stream))
-            (include rel i (read stream)))))))
+            (include rel (arc i (read stream))))))))
   rel)


@@ -541,25 +536,25 @@ RETURN: REL.
   (princ "(" stream)
   (for (i 0 (brelation-size-1 rel))
        (princ i stream)
-       (com.informatimago.common-lisp.cesarum.bset:write-bset stream (adjref rel i))
+       (write-bset stream (adjref rel i))
        (terpri stream))
   (princ ")" stream)
   rel)

-
-(defun project-1 (rel e1 bset)
+(defgeneric project-1 (rel e1 bset))
+(defmethod project-1 ((rel brelation) e1 (bset bset))
   "
 POST:   BSET is the set of all elements I that are in relation REL(I,E2).
 RETURN: BSET
 "
   (assign-empty bset)
   (for (i 0 (brelation-size-1 rel))
-       (when (related rel i e1)
-         (com.informatimago.common-lisp.cesarum.bset:include bset i)))
+    (when (related rel i e1)
+      (include bset i)))
   bset)

-
-(defun project-2 (rel e1 bset)
+(defgeneric project-2 (rel e1 bset))
+(defmethod project-2 ((rel brelation) e1 (bset bset))
   "
 POST:   BSET is the set of all elements E2 that are in relation REL(E1,E2).
 RETURN: BSET
diff --git a/common-lisp/cesarum/bset.lisp b/common-lisp/cesarum/bset.lisp
index bf67f93..f050398 100644
--- a/common-lisp/cesarum/bset.lisp
+++ b/common-lisp/cesarum/bset.lisp
@@ -44,14 +44,15 @@
 (in-package "COMMON-LISP-USER")
 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BSET"
   (:use "COMMON-LISP")
+  (:shadow "COMPLEMENT" "INTERSECTION" "UNION" "SET" "SUBSETP")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "VECTOR-INIT" "FOR")
   (:export "BSET-TO-LIST" "LIST-TO-BSET" "WRITE-BSET" "READ-BSET" "FOR-ALL-DO"
            "ASSIGN-EMPTY" "ASSIGN-ELEMENT" "ASSIGN" "EXISTS-1" "EXISTS" "FOR-ALL"
            "IS-EMPTY" "IS-ELEMENT" "IS-EQUAL" "IS-STRICT-SUBSET" "IS-SUBSET" "EXTRACT"
            "SELECT" "MAXIMUM" "MINIMUM" "SIZE" "CARDINAL" "EXCLUDE" "INCLUDE"
            "COMPLEMENT" "SYM-DIFF" "INTERSECTION" "DIFFERENCE" "UNION" "RESIZE-BSET"
-           "COPY-BSET" "MAKE-BSET" "BSET")
-  (:shadow "COMPLEMENT" "INTERSECTION" "UNION" "SET")
-  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "VECTOR-INIT" "FOR")
+           "COPY-BSET" "MAKE-BSET" "BSET"
+           "SUBSETP" "STRICT-SUBSETP" )
   (:documentation
    "

@@ -64,7 +65,7 @@ License:

     AGPL3

-    Copyright Pascal J. Bourguignon 2004 - 2012
+    Copyright Pascal J. Bourguignon 2004 - 2015

     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU Affero General Public License as published by
@@ -204,8 +205,8 @@ RETURN:  bset
     bset))


-
-(defun union (set1 set2)
+(defgeneric union (s1 s2))
+(defmethod union ((set1 bset) (set2 bset))
   "
 DO:      set1 := set1 U ( set2 inter (complement (make-bset (size set1))) )
          Accumulate in set1 the union of set1 and set2
@@ -226,8 +227,8 @@ RETURN:  SET1
                                        (bset-last-element set2)))
   set1)

-
-(defun difference (set1 set2)
+(defgeneric difference (s1 s2))
+(defmethod difference ((set1 bset) (set2 bset))
   "
 DO:      set1 := set1 - ( set2 inter (complement (make-bset (size set1))) )
          Accumulate in set1 the difference of set1 and set2
@@ -247,8 +248,8 @@ RETURN:  SET1
   (setf (bset-cardinal set1) nil)
   set1)

-
-(defun intersection (set1 set2)
+(defgeneric intersection (s1 s2))
+(defmethod intersection ((set1 bset) (set2 bset))
   "
 DO:      set1 := set1 inter set2 inter
          Accumulate in set1 the intersection of set1 and set2
@@ -270,9 +271,8 @@ RETURN:  SET1
                                        (bset-last-element set2)))
   set1)

-
-
-(defun sym-diff (set1 set2)
+(defgeneric sym-diff (s1 s2))
+(defmethod sym-diff ((set1 bset) (set2 bset))
   "
 DO:      set1 := set1 delta ( set2 inter (complement (make-bset (size set1))) )
          Accumulate in set1 the symetrical difference of set1 and set2
@@ -296,8 +296,8 @@ RETURN:  SET1
                                        (bset-last-element set2)))
   set1)

-
-(defun complement (bset)
+(defgeneric complement (s))
+(defmethod complement ((bset bset))
   "
 DO:      set1 := (complement (make-bset (size set1))) - set1
          Accumulate in set1 the complement of set1
@@ -316,8 +316,8 @@ RETURN:  SET1
           (bset-last-element  bset) (1- (bitset-to-elem (last-bitset bits)))))
   bset)

-
-(defun include (bset element)
+(defgeneric include (set element))
+(defmethod include ((bset bset) element)
   "
 PRE:    (<= 0 element (size bset))
 POST:   (is-element element bset)
@@ -334,8 +334,8 @@ RETURN: BSET
   bset)


-
-(defun exclude (bset element)
+(defgeneric exclude (set element))
+(defmethod exclude ((bset bset) element)
   "
 PRE:    (<= 0 element (size bset))
 POST:   (not (is-element element bset))
@@ -355,8 +355,8 @@ RETURN: BSET
       (decf (bset-last-element bset))))
   bset)

-
-(defun cardinal (bset)
+(defgeneric cardinal (set))
+(defmethod cardinal ((bset bset))
   "
 RETURN:  The number of elements in BSET.
 "
@@ -368,7 +368,8 @@ RETURN:  The number of elements in BSET.
   (bset-cardinal bset))


-(defun size (bset)
+(defgeneric size (bset))
+(defmethod size ((bset bset))
   "
 RETURN:  The maximum element BSET can hold.
 "
@@ -376,32 +377,35 @@ RETURN:  The maximum element BSET can hold.
     (1- (bitset-to-elem (last-bitset bits)))))


-(defun minimum (bset)
+(defgeneric minimum (bset))
+(defmethod minimum ((bset bset))
   "
 PRE:     (not (is-empty bset))
 RETURN:  The smallest element of BSET.
 "
   (for (i (bset-first-element bset)  (bset-last-element bset))
-       (when (is-element i bset)
-         (setf (bset-first-element bset) i)
-         (return-from minimum i)))
+    (when (is-element i bset)
+      (setf (bset-first-element bset) i)
+      (return-from minimum i)))
   0)


-(defun maximum (bset)
+(defgeneric maximum (bset))
+(defmethod maximum ((bset bset))
   "
 PRE:     (not (is-empty bset))
 RETURN:  The greatest element of BSET.
 "
   (for (i (bset-last-element bset)  (bset-first-element bset))
-       (when (is-element i bset)
-         (setf (bset-last-element bset) i)
-         (return-from maximum i)))
+    (when (is-element i bset)
+      (setf (bset-last-element bset) i)
+      (return-from maximum i)))
   0)



-(defun select (bset)
+(defgeneric select (bset))
+(defmethod select ((bset bset))
   "
 PRE:      (not (is-empty bset))
 RETURN:   An element of BSET.
@@ -410,7 +414,8 @@ WARNING:  May return always the same element if it's not removed from the BSET.
   (minimum bset))


-(defun extract (bset)
+(defgeneric extract (bset))
+(defmethod extract ((bset bset))
   "
 PRE:      (not (is-empty bset))
 POST:     (not (is-element (extract bset) bset))
@@ -420,7 +425,12 @@ RETURN:   An element that was in BSET.
   (let ((i (minimum bset))) (exclude bset i) i))


-(defun is-subset (set1 set2)
+(defgeneric is-subset (set1 set2)
+  (:method (set1 set2)
+    (subsetp set1 set2)))
+
+(defgeneric subsetp (set1 set2))
+(defmethod subsetp ((set1 bset) (set2 bset))
   "
 RETURN:  Whether  SET1 is a subset of SET2.
 "
@@ -433,30 +443,35 @@ RETURN:  Whether  SET1 is a subset of SET2.
   (let ((bits1 (bset-bitsets set1))
         (bits2 (bset-bitsets set2)))
     (for (i (elem-to-bitset (bset-first-element set1))
-            (elem-to-bitset (min (bset-last-element set1)
-                                 (bset-last-element set2))))
-         (cond
-           ((= 0 (bsref bits1 i)))
-           ((= 0 (bsref bits2 i))
-            (return-from is-subset nil))
-           ((/= 0 (logandc2 (bsref bits1 i) (bsref bits2 i)))
-            (return-from is-subset nil)))
-         (when (> (bset-last-element set1) (bset-last-element set2))
-           (for (i (1+ (elem-to-bitset (bset-last-element set1)))
-                   (elem-to-bitset (bset-last-element set2)))
-                (when (/= 0 (bsref bits1 i))
-                  (return-from is-subset nil))))))
+           (elem-to-bitset (min (bset-last-element set1)
+                                (bset-last-element set2))))
+      (cond
+        ((= 0 (bsref bits1 i)))
+        ((= 0 (bsref bits2 i))
+         (return-from subsetp nil))
+        ((/= 0 (logandc2 (bsref bits1 i) (bsref bits2 i)))
+         (return-from subsetp nil)))
+      (when (> (bset-last-element set1) (bset-last-element set2))
+        (for (i (1+ (elem-to-bitset (bset-last-element set1)))
+               (elem-to-bitset (bset-last-element set2)))
+          (when (/= 0 (bsref bits1 i))
+            (return-from subsetp nil))))))
   t)

+(defgeneric is-strict-subset (set1 set2)
+  (:method (set1 set2)
+    (strict-subsetp set1 set2)))

-(defun is-strict-subset (set1 set2)
+(defgeneric strict-subsetp (set1 set2))
+(defmethod strict-subsetp ((set1 bset) (set2 bset))
   "
 RETURN:  Whether SET1 is a strict subset of SET2.
 "
-  (and (is-subset set1 set2) (not (is-equal set1 set2))))
+  (and (subsetp set1 set2) (not (is-equal set1 set2))))


-(defun is-equal (set1 set2)
+(defgeneric is-equal (set1 set2))
+(defmethod is-equal ((set1 bset) (set2 bset))
   "
 RETURN:  Whether SET1 and SET2 contain the same elements.
   "
@@ -464,41 +479,43 @@ RETURN:  Whether SET1 and SET2 contain the same elements.
       (let ((bits1 (bset-bitsets set1))
             (bits2 (bset-bitsets set2)))
         (for (i
-               (elem-to-bitset (min (bset-first-element set1)
-                                    (bset-first-element set2)))
+                 (elem-to-bitset (min (bset-first-element set1)
+                                      (bset-first-element set2)))
                (elem-to-bitset (min (bset-last-element set1)
                                     (bset-last-element set2))))
-             (unless (= (bsref bits1 i) (bsref bits2 i))
-               (return-from is-equal nil)))
+          (unless (= (bsref bits1 i) (bsref bits2 i))
+            (return-from is-equal nil)))
         (when (> (elem-to-bitset (size set1))
                  (elem-to-bitset (bset-last-element set1))
                  (elem-to-bitset (bset-last-element set2)))
           (for (i
-                 (1+ (elem-to-bitset (min (bset-last-element set1)
-                                          (bset-last-element set2))))
+                   (1+ (elem-to-bitset (min (bset-last-element set1)
+                                            (bset-last-element set2))))
                  (elem-to-bitset (size set1)))
-               (when (/= 0 (bsref bits1 i))
-                 (return-from is-equal nil))))
+            (when (/= 0 (bsref bits1 i))
+              (return-from is-equal nil))))
         (when (> (elem-to-bitset (size set2))
                  (elem-to-bitset (bset-last-element set2))
                  (elem-to-bitset (bset-last-element set1)))
           (for (i
-                 (1+ (elem-to-bitset (min (bset-last-element set1)
-                                          (bset-last-element set2))))
+                   (1+ (elem-to-bitset (min (bset-last-element set1)
+                                            (bset-last-element set2))))
                  (elem-to-bitset (size set2)))
-               (when (/= 0 (bsref bits2 i))
-                 (return-from is-equal nil))))
+            (when (/= 0 (bsref bits2 i))
+              (return-from is-equal nil))))
         t)))


-(defun is-not-equal (set1 set2)
+(defgeneric is-not-equal (set1 set2))
+(defmethod is-not-equal ((set1 bset) (set2 bset))
   "
 RETURN:  (not (is-equal set1 set2))
 "
   (not (is-equal set1 set2)))


-(defun is-element (element bset)
+(defgeneric is-element (element bset))
+(defmethod is-element (element (bset bset))
   "
 RETURN:  Whether element is in BSET.
 "
@@ -508,55 +525,62 @@ RETURN:  Whether element is in BSET.
          (/= 0 (logand (bsref bits (elem-to-bitset element))
                        (ash 1 (elem-to-bit element)))))))

+(defgeneric is-empty (set)
+  (:method (set) (emptyp set)))

-(defun is-empty (bset)
+(defgeneric emptyp (set))
+(defmethod emptyp ((bset bset))
   "
 RETURN: (= 0 (cardinal bset))
 "
   (or (and (bset-cardinal bset) (= 0 (bset-cardinal bset)))
       (let ((bits (bset-bitsets bset)))
         (for (i 0 (last-bitset bits))
-             (when (/= 0 (bsref bits i)) (return-from is-empty nil)))
+          (when (/= 0 (bsref bits i)) (return-from is-empty nil)))
         (setf (bset-cardinal bset) 0)
         t)))


-(defun for-all (bset proc)
+(defgeneric for-all (bset proc))
+(defmethod for-all ((bset bset) proc)
   "
 DO:     Call function PROC for each element in the BSET until PROC returns NIL.
 RETURN: Whether no call to PROC returned NIL.
 "
   (for (i (bset-first-element bset) (bset-last-element bset))
-       (when (and (is-element i bset) (not (funcall proc i)))
-         (return-from for-all nil)))
+    (when (and (is-element i bset) (not (funcall proc i)))
+      (return-from for-all nil)))
   t)


-(defun exists (bset proc)
+(defgeneric exists (bset proc))
+(defmethod exists ((bset bset) proc)
   "
 DO:      Call function PROC for each element in the BSET
          until PROC returns non nil.
 RETURN:  Whether PROC returned non nil.
 "
   (for (i (bset-first-element bset) (bset-last-element bset))
-       (when (and (is-element i bset) (funcall proc i))
-         (return-from exists t)))
+    (when (and (is-element i bset) (funcall proc i))
+      (return-from exists t)))
   nil)


-(defun exists-1 (bset proc)
+(defgeneric exists-1 (bset proc))
+(defmethod exists-1 ((bset bset) proc)
   "
 DO:       Call function PROC on all elements in the BSET.
 RETURN:   Whether PROC returned non nil for exactly one element.
 "
   (let ((n 0))
     (for (i (bset-first-element bset) (bset-last-element bset))
-         (when (and (is-element i bset) (funcall proc i))
-           (incf n)))
+      (when (and (is-element i bset) (funcall proc i))
+        (incf n)))
     (= n 1)))


-(defun assign (set1 set2)
+(defgeneric assign (set1 set2))
+(defmethod assign ((set1 bset) (set2 bset))
   "
 DO:      Accumulate in set1 the elements of set2 that are less than (size set1).
 POST:    (is-equal set1 (intersection (complement (make-bset (size set1)))set2))
@@ -565,11 +589,11 @@ RETURN:  SET1
   (let ((bits1 (bset-bitsets set1))
         (bits2 (bset-bitsets set2)))
     (for (i 0 (min (last-bitset bits1) (last-bitset bits2)))
-         (setf (bsref bits1 i) (bsref bits2 i)))
+      (setf (bsref bits1 i) (bsref bits2 i)))
     (when (< (min (last-bitset bits1) (last-bitset bits2)) (last-bitset bits1))
       (for (i (1+ (min (last-bitset bits1) (last-bitset bits2)))
-              (last-bitset bits1))
-           (setf (bsref bits1 i) 0)))
+             (last-bitset bits1))
+        (setf (bsref bits1 i) 0)))
     (setf (bset-cardinal set1) (bset-cardinal set2)
           (bset-first-element set1) (min (bset-first-element set2)
                                          (bitset-to-elem (last-bitset bits1)))
@@ -578,7 +602,8 @@ RETURN:  SET1
   set1)


-(defun assign-element (bset element)
+(defgeneric assign-element (bset element))
+(defmethod assign-element ((bset bset) element)
   "
 DO:     Empties BSET and include element.
 PRE:    (<= 0 element (size bset))
@@ -595,7 +620,8 @@ RETURN:  BSET
   bset)


-(defun assign-empty (bset)
+(defgeneric assign-empty (bset))
+(defmethod assign-empty ((bset bset))
   "
 POST:    (is-empty bset)
 RETURN:  BSET.
@@ -608,25 +634,27 @@ RETURN:  BSET.
   bset)


-(defun for-all-do (bset proc)
+(defgeneric for-all-do (bset proc))
+(defmethod for-all-do ((bset bset) proc)
   "
 DO:      Call PROC on all elements in BSET.
 RETURN:  BSET.
 "
   (for (i (bset-first-element bset) (bset-last-element bset))
-       (when (is-element i bset)
-         (funcall proc i)))
+    (when (is-element i bset)
+      (funcall proc i)))
   bset)


-(defun bset-to-list (bset)
+(defgeneric bset-to-list (bset))
+(defmethod bset-to-list ((bset bset))
   "
 RETURN:  A list of all elements of BSET, sorted in increasing order.
 "
   (let ((elements '()))
     (for (i (bset-last-element bset) (bset-first-element bset))
-         (when (is-element i bset)
-           (push i elements)))
+      (when (is-element i bset)
+        (push i elements)))
     elements))

ViewGit