[isidorus-cvs] r254 - in branches/new-datamodel/src: model unit_tests

Lukas Giessmann lgiessmann at common-lisp.net
Sat Mar 27 20:30:13 UTC 2010


Author: lgiessmann
Date: Sat Mar 27 16:30:12 2010
New Revision: 254

Log:
new-datamodel: added the generic "equivalent-constructs" that checks the TMDM equality of two "TopicMapConstructC"s and is needed for "merge-constructs"

Modified:
   branches/new-datamodel/src/model/datamodel.lisp
   branches/new-datamodel/src/unit_tests/datamodel_test.lisp

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Sat Mar 27 16:30:12 2010
@@ -155,7 +155,6 @@
 (in-package :datamodel)
 
 
-
 ;;TODO: check merge-constructs in add-topic-identifier,
 ;;      add-item-identifier/add-reifier (can merge the parent constructs
 ;;      and the parent's parent construct + the reifier constructs),
@@ -779,7 +778,14 @@
 (defgeneric equivalent-construct (construct &key start-revision
 					    &allow-other-keys)
   (:documentation "Returns t if the passed construct is equivalent to the passed
-                   key arguments (TMDM equality rules. Parent-equality is not
+                   key arguments (TMDM equality rules). Parent-equality is not
+                   checked in this methods, so the user has to pass children of
+                   the same parent."))
+
+
+(defgeneric equivalent-constructs (construct-1 construct-2 &key revision)
+  (:documentation "Returns t if the passed constructs are equivalent to each
+                   other (TMDM equality rules). Parent-equality is not
                    checked in this methods, so the user has to pass children of
                    the same parent."))
 
@@ -923,6 +929,17 @@
   
 
 ;;; TopicMapconstructC
+(defgeneric strictly-equivalent-constructs (construct-1 construct-2
+							&key revision)
+  (:documentation "Checks if two topic map constructs are not identical but
+                   equal according to the TMDM equality rules.")
+  (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapConstructC)
+	    &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (and (equivalent-constructs construct-1 construct-2 :revision revision)
+	 (not (eql construct-1 construct-2)))))
+
+
 (defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)
 					    &key revision)
   (declare (ignorable revision construct))
@@ -948,6 +965,12 @@
 
 
 ;;; PointerC
+(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC)
+				  &key (revision nil))
+  (declare (ignorable revision))
+  (string= (uri construct-1) (uri construct-2)))
+
+
 (defgeneric PointerC-p (class-symbol)
   (:documentation "Returns t if the passed symbol corresponds to the class
                    PointerC or one of its subclasses.")
@@ -1018,6 +1041,14 @@
 
 
 ;;; TopicIdentificationC
+(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC)
+				  &key (revision nil))
+  (declare (ignorable revision))
+  (and (call-next-method)
+       (string= (xtm-id construct-1) (xtm-id construct-2))))
+       
+
+
 (defgeneric TopicIdentificationC-p (class-symbol)
   (:documentation "Returns t if the passed class symbol is equal
                    to TopicIdentificationC.")
@@ -1143,6 +1174,20 @@
 
 
 ;;; TopicC
+(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC)
+				  &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (when (intersection (union
+		       (union (item-identifiers construct-1 :revision revision)
+			      (locators construct-1 :revision revision))
+		       (psis construct-1 :revision revision))
+		      (union 
+		       (union (item-identifiers construct-2 :revision revision)
+			      (locators construct-2 :revision revision))
+		       (psis construct-2 :revision revision)))
+    t))
+
+
 (defgeneric TopicC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to TopicC.")
   (:method ((class-symbol symbol))
@@ -1714,6 +1759,17 @@
 
 
 ;;; CharacteristicC
+(defmethod equivalent-constructs ((construct-1 CharacteristicC)
+				  (construct-2 CharacteristicC)
+				  &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (and (string= (charvalue construct-1) (charvalue construct-2))
+       (eql (instance-of construct-1 :revision revision)
+	    (instance-of construct-2 :revision revision))
+       (not (set-exclusive-or (themes construct-1 :revision revision)
+			      (themes construct-2 :revision revision)))))
+
+
 (defgeneric CharacteristicC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to CharacteristicC
                    or one of its subtypes.")
@@ -1845,6 +1901,13 @@
 
 
 ;;; OccurrenceC
+(defmethod equivalent-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC)
+				  &key (revision *TM-REVISION*))
+  (declare (ignorable revision))
+  (and (call-next-method)
+       (string= (datatype construct-1) (datatype construct-2))))
+
+
 (defgeneric OccurrenceC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to OccurrenceC.")
   (:method ((class-symbol symbol))
@@ -1867,6 +1930,13 @@
 
 
 ;;; VariantC
+(defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC)
+				  &key (revision *TM-REVISION*))
+  (declare (ignorable revision))
+  (and (call-next-method)
+       (string= (datatype construct-1) (datatype construct-2))))
+
+
 (defgeneric VariantC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to VariantC.")
   (:method ((class-symbol symbol))
@@ -1977,6 +2047,18 @@
 
 
 ;;; AssociationC
+(defmethod equivalent-constructs ((construct-1 AssociationC)
+				  (construct-2 AssociationC)
+				  &key (revision *TM-REVISION*))
+  (declare (ignorable revision))
+  (and (eql (instance-of construct-1 :revision revision)
+	    (instance-of construct-2 :revision revision))
+       (not (set-exclusive-or (themes construct-1 :revision revision)
+			      (themes construct-1 :revision revision)))
+       (not (set-exclusive-or (roles construct-1 :revision revision)
+			      (roles construct-2 :revision revision)))))
+
+
 (defgeneric AssociationC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to AssociationC.")
   (:method ((class-symbol symbol))
@@ -2082,6 +2164,15 @@
 
 
 ;;; RoleC
+(defmethod equivalent-constructs ((construct-1 RoleC) (construct-2 RoleC)
+				  &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (and (eql (instance-of construct-1 :revision revision)
+	    (instance-of construct-2 :revision revision))
+       (eql (player construct-1 :revision revision)
+	    (player construct-1 :revision revision))))
+
+
 (defgeneric RoleC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to RoleC.")
   (:method ((class-symbol symbol))
@@ -2364,6 +2455,11 @@
 	   (let ((id-owner (identified-construct item-identifier
 						 :revision revision)))
 	     (when (not (eql id-owner construct))
+	       (unless (typep construct 'TopicC)
+		 (error (make-condition 'duplicate-identifier-error
+					:message "From add-item-identifier(): duplicate ItemIdentifier has been found: ~a"
+					(uri item-identifier)
+					:uri (uri item-identifier))))
 	       id-owner))))
       (let ((merged-construct construct))
 	(cond (construct-to-be-merged
@@ -2649,6 +2745,14 @@
 
 
 ;;; TopicMapC
+(defmethod equivalent-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC)
+				  &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (when (intersection (item-identifiers construct-1 :revision revision)
+		      (item-identifiers construct-2 :revision revision))
+    t))
+
+
 (defgeneric TopicMapC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to TopicMapC.")
   (:method ((class-symbol symbol))

Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp	(original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp	Sat Mar 27 16:30:12 2010
@@ -75,6 +75,7 @@
 	   :test-make-TopicC))
 
 
+;;TODO: test equivalent-constructs
 ;;TODO: test merge-constructs
 
 




More information about the Isidorus-cvs mailing list