[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