[isidorus-cvs] r255 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Apr 1 09:40:23 UTC 2010
Author: lgiessmann
Date: Thu Apr 1 05:40:23 2010
New Revision: 255
Log:
new-datamodel: added the generic "find-oldest-construct" which is needed for "merge-constructs"; added unit-tests for "find-oldest-constructs" and "equivalent-constructs"; fixed a bug in "eqiuvalent-constructs" --> AssociaitonC; fixed a bug in "make-topic" which caused problems when adding topic-identifiers.
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 Thu Apr 1 05:40:23 2010
@@ -617,9 +617,23 @@
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun find-version-info (versioned-constructs
+ &key (sort-function #'<) (sort-key 'start-revision))
+ "Returns all version-infos sorted by the function sort-function which is
+ applied on the slot sort-key."
+ (declare (list versioned-constructs))
+ (let ((vis
+ (sort
+ (loop for vc in versioned-constructs
+ append (versions vc))
+ sort-function :key sort-key)))
+ (when vis
+ (first vis))))
+
+
(defun rec-remf (plist keyword)
"Calls remf for the past plist with the given keyword until
- all key-value-pairs corresponding to the passed keyword were removed."
+ all key-value-pairs corresponding to the passed keyword were removed."
(declare (list plist) (keyword keyword))
(loop while (getf plist keyword)
do (remf plist keyword))
@@ -741,6 +755,20 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric find-oldest-construct (construct-1 construct-2)
+ (:documentation "Returns the construct which owns the oldes version info.
+ If a construct is not a versioned construct the oldest
+ association determines the construct's version info."))
+
+
+(defgeneric merge-constructs (construct-1 construct-2 &key revision)
+ (:documentation "Merges two constructs of the same type if they are
+ mergable. The latest construct will be marked as deleted
+ The older one gets all characteristics of the marked as
+ deleted one. All referenced constructs are also updated
+ with the changeds that are caused by this operation."))
+
+
(defgeneric delete-parent (construct parent-construct &key revision)
(:documentation "Sets the assoication-object between the passed
constructs as marded-as-deleted."))
@@ -824,6 +852,22 @@
;;; VersionedConstructC
+(defmethod find-oldest-construct ((construct-1 VersionedConstructC)
+ (construct-2 VersionedConstructC))
+ (let ((vi-1 (find-version-info (list construct-1)))
+ (vi-2 (find-version-info (list construct-2))))
+ (cond ((not (or vi-1 vi-2))
+ nil)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
(defgeneric VersionedConstructC-p (class-symbol)
(:documentation "Returns t if the passed class is equal to VersionedConstructC
or one of its subtypes.")
@@ -965,6 +1009,21 @@
;;; PointerC
+(defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct)))
+ (vi-2 (find-version-info (slot-p construct-2 'identified-construct))))
+ (cond ((not (or vi-1 vi-2))
+ nil)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC)
&key (revision nil))
(declare (ignorable revision))
@@ -1041,7 +1100,8 @@
;;; TopicIdentificationC
-(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC)
+(defmethod equivalent-constructs ((construct-1 TopicIdentificationC)
+ (construct-2 TopicIdentificationC)
&key (revision nil))
(declare (ignorable revision))
(and (call-next-method)
@@ -1177,15 +1237,14 @@
(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))
+ (let ((ids-1 (union (union (item-identifiers construct-1 :revision revision)
+ (locators construct-1 :revision revision))
+ (psis construct-1 :revision revision)))
+ (ids-2 (union (union (item-identifiers construct-2 :revision revision)
+ (locators construct-2 :revision revision))
+ (psis construct-2 :revision revision))))
+ (when (intersection ids-1 ids-2)
+ t)))
(defgeneric TopicC-p (class-symbol)
@@ -1195,7 +1254,7 @@
(defmethod equivalent-construct ((construct TopicC)
- &key (start-revision 0) (psis nil)
+ &key (start-revision *TM-REVISION*) (psis nil)
(locators nil) (item-identifiers nil)
(topic-identifiers nil))
"Isidorus handles Topic-equality only by the topic's identifiers
@@ -1759,6 +1818,22 @@
;;; CharacteristicC
+(defmethod find-oldest-construct ((construct-1 CharacteristicC)
+ (construct-2 CharacteristicC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
+ (vi-2 (find-version-info (slot-p construct-2 'parent))))
+ (cond ((not (or vi-1 vi-2))
+ nil)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
(defmethod equivalent-constructs ((construct-1 CharacteristicC)
(construct-2 CharacteristicC)
&key (revision *TM-REVISION*))
@@ -2164,13 +2239,28 @@
;;; RoleC
+(defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
+ (vi-2 (find-version-info (slot-p construct-2 'parent))))
+ (cond ((not (or vi-1 vi-2))
+ nil)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
(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))))
+ (player construct-2 :revision revision))))
(defgeneric RoleC-p (class-symbol)
@@ -2455,11 +2545,6 @@
(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
@@ -2890,7 +2975,6 @@
(apply #'make-construct 'RoleC
(append role-plist (list :parent association)))
:revision (getf role-plist :start-revision)))
- (format t "~%~%~%")
association)))
@@ -2997,6 +3081,9 @@
(t
(make-instance 'TopicC))))))
(let ((merged-topic topic))
+ (dolist (tid topic-identifiers)
+ (setf merged-topic (add-topic-identifier merged-topic tid
+ :revision start-revision)))
(dolist (psi psis)
(setf merged-topic (add-psi merged-topic psi
:revision start-revision)))
@@ -3134,9 +3221,39 @@
;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defgeneric merge-constructs(construct-1 construct-2 &key revision)
- (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
- &key (revision *TM-REVISION*))
- (or revision)
- (if construct-1 construct-1 construct-2)))
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
\ No newline at end of file
+(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+ &key (revision *TM-REVISION*))
+ (or revision)
+ (if construct-1 construct-1 construct-2))
+;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (progn
+ (unless
+ (equivalent-constructs construct-1 construct-2 :revision revision)
+ (error "From merge-constructs(): the variants: ~a ~a are not mergable"
+ construct-1 construct-2))
+ ;;...
+ )))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
\ No newline at end of file
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 Thu Apr 1 05:40:23 2010
@@ -17,7 +17,8 @@
(:import-from :exceptions
duplicate-identifier-error)
(:import-from :constants
- *xml-string*)
+ *xml-string*
+ *xml-uri*)
(:export :run-datamodel-tests
:datamodel-test
:test-VersionInfoC
@@ -72,7 +73,8 @@
:test-make-RoleC
:test-make-TopicMapC
:test-make-AssociationC
- :test-make-TopicC))
+ :test-make-TopicC
+ :test-find-oldest-construct))
;;TODO: test equivalent-constructs
@@ -1527,13 +1529,23 @@
(test test-equivalent-PointerC ()
- "Tests the functions equivalent-construct depending on PointerC
- and its subclasses."
+ "Tests the functions equivalent-construct and strictly-equivalent-constructs
+ depending on PointerC and its subclasses."
(with-fixture with-empty-db (*db-dir*)
(let ((p-1 (make-instance 'd::PointerC :uri "p-1"))
(tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1"
:xtm-id "xtm-1"))
- (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1")))
+ (tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2"
+ :xtm-id "xtm-1"))
+ (tid-3 (make-instance 'd:TopicIdentificationC :uri "tid-1"
+ :xtm-id "xtm-2"))
+ (tid-4 (make-instance 'd:TopicIdentificationC :uri "tid-1"
+ :xtm-id "xtm-1"))
+ (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1"))
+ (psi-2 (make-instance 'd:PersistentIdC :uri "psi-2"))
+ (psi-3 (make-instance 'd:PersistentIdC :uri "psi-1"))
+ (rev-1 100))
+ (setf *TM-REVISION* rev-1)
(is-true (d::equivalent-construct p-1 :uri "p-1"))
(is-false (d::equivalent-construct p-1 :uri "p-2"))
(is-true (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-1"))
@@ -1541,138 +1553,250 @@
(is-false (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-2"))
(is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-2"))
(is-true (d::equivalent-construct psi-1 :uri "psi-1"))
- (is-false (d::equivalent-construct psi-1 :uri "psi-2")))))
+ (is-false (d::equivalent-construct psi-1 :uri "psi-2"))
+ (is-false (d::strictly-equivalent-constructs tid-1 tid-1))
+ (is-false (d::strictly-equivalent-constructs tid-1 tid-2))
+ (is-false (d::strictly-equivalent-constructs tid-1 tid-3))
+ (is-true (d::strictly-equivalent-constructs tid-1 tid-4))
+ (is-false (d::strictly-equivalent-constructs psi-1 psi-1))
+ (is-false (d::strictly-equivalent-constructs psi-1 psi-2))
+ (is-true (d::strictly-equivalent-constructs psi-1 psi-3)))))
(test test-equivalent-OccurrenceC ()
"Tests the functions equivalent-construct depending on OccurrenceC."
(with-fixture with-empty-db (*db-dir*)
- (let ((occ-1 (make-instance 'd:OccurrenceC :charvalue "occ-1"))
- (type-1 (make-instance 'd:TopicC))
+ (let ((type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
(scope-1 (make-instance 'd:TopicC))
(scope-2 (make-instance 'd:TopicC))
(scope-3 (make-instance 'd:TopicC))
- (revision-0-5 50)
- (version-1 100))
- (setf *TM-REVISION* version-1)
- (add-type occ-1 type-1)
- (add-theme occ-1 scope-1)
- (add-theme occ-1 scope-2)
- (is-true (d::equivalent-construct
- occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
- :instance-of type-1 :themes (list scope-2 scope-1)))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
- :instance-of type-1 :themes (list scope-2 scope-1)
- :start-revision revision-0-5))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
- :instance-of type-2 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
- :instance-of type-1 :themes (list scope-3 scope-2)))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-1"
- :instance-of type-1 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-2" :datatype constants:*xml-string*
- :instance-of type-1 :themes (list scope-2 scope-1))))))
+ (rev-0-5 50)
+ (rev-1 100))
+ (let ((occ-1 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (occ-2 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :instance-of type-2
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (occ-3 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list scope-3 scope-2)
+ :start-revision rev-1))
+ (occ-4 (make-construct 'OccurrenceC
+ :charvalue "occ-2"
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (occ-5 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :datatype *xml-uri*
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (occ-6 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list scope-1)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-theme occ-6 scope-2)
+ (is-true (d::equivalent-construct
+ occ-1 :charvalue "occ-1" :datatype *xml-string*
+ :instance-of type-1 :themes (list scope-2 scope-1)))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-1" :datatype *xml-string*
+ :instance-of type-1 :themes (list scope-2 scope-1)
+ :start-revision rev-0-5))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-1" :datatype *xml-string*
+ :instance-of type-2 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-1" :datatype *xml-string*
+ :instance-of type-1 :themes (list scope-3 scope-2)))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-1"
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-2" :datatype *xml-string*
+ :instance-of type-1 :themes (list scope-2 scope-1)))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-1))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-2))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-3))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-4))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-5))
+ (is-true (d::strictly-equivalent-constructs occ-1 occ-6))))))
(test test-equivalent-NameC ()
"Tests the functions equivalent-construct depending on NameC."
(with-fixture with-empty-db (*db-dir*)
- (let ((nam-1 (make-instance 'd:NameC :charvalue "nam-1"))
- (type-1 (make-instance 'd:TopicC))
+ (let ((type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
(scope-1 (make-instance 'd:TopicC))
(scope-2 (make-instance 'd:TopicC))
(scope-3 (make-instance 'd:TopicC))
- (revision-0-5 50)
- (version-1 100))
- (setf *TM-REVISION* version-1)
- (add-type nam-1 type-1)
- (add-theme nam-1 scope-1)
- (add-theme nam-1 scope-2)
- (is-true (d::equivalent-construct
- nam-1 :charvalue "nam-1" :instance-of type-1
- :themes (list scope-2 scope-1)))
- (is-false (d::equivalent-construct
- nam-1 :charvalue "nam-1" :instance-of type-1
- :themes (list scope-2 scope-1)
- :start-revision revision-0-5))
- (is-false (d::equivalent-construct
- nam-1 :charvalue "nam-1" :instance-of type-2
- :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- nam-1 :charvalue "nam-1" :instance-of type-1
- :themes (list scope-3 scope-2)))
- (is-false (d::equivalent-construct
- nam-1 :charvalue "nam-2" :instance-of type-1
- :themes (list scope-2 scope-1))))))
+ (variant-1 (make-instance 'd:VariantC))
+ (variant-2 (make-instance 'd:VariantC))
+ (rev-0-5 50)
+ (rev-1 100))
+ (let ((name-1 (make-construct 'NameC
+ :charvalue "name-1"
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (name-2 (make-construct 'NameC
+ :charvalue "name-2"
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (name-3 (make-construct 'NameC
+ :charvalue "name-1"
+ :instance-of type-2
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (name-4 (make-construct 'NameC
+ :charvalue "name-1"
+ :instance-of type-1
+ :themes (list scope-3 scope-2)
+ :start-revision rev-1))
+ (name-5 (make-construct 'NameC
+ :charvalue "name-1"
+ :instance-of type-1
+ :themes (list scope-2)
+ :variants (list variant-1 variant-2)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-theme name-5 scope-1)
+ (is-true (d::equivalent-construct
+ name-1 :charvalue "name-1" :instance-of type-1
+ :themes (list scope-2 scope-1)))
+ (is-false (d::equivalent-construct
+ name-1 :charvalue "name-1" :instance-of type-1
+ :themes (list scope-2 scope-1)
+ :start-revision rev-0-5))
+ (is-false (d::equivalent-construct
+ name-1 :charvalue "name-1" :instance-of type-2
+ :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ name-1 :charvalue "name-1" :instance-of type-1
+ :themes (list scope-3 scope-2)))
+ (is-false (d::equivalent-construct
+ name-1 :charvalue "name-2" :instance-of type-1
+ :themes (list scope-2 scope-1)))
+ (is-false (d::strictly-equivalent-constructs name-1 name-1))
+ (is-false (d::strictly-equivalent-constructs name-1 name-2))
+ (is-false (d::strictly-equivalent-constructs name-1 name-3))
+ (is-false (d::strictly-equivalent-constructs name-1 name-4))
+ (is-true (d::strictly-equivalent-constructs name-1 name-5))))))
(test test-equivalent-VariantC ()
"Tests the functions equivalent-construct depending on VariantC."
(with-fixture with-empty-db (*db-dir*)
- (let ((var-1 (make-instance 'd:OccurrenceC :charvalue "var-1"))
- (scope-1 (make-instance 'd:TopicC))
+ (let ((scope-1 (make-instance 'd:TopicC))
(scope-2 (make-instance 'd:TopicC))
(scope-3 (make-instance 'd:TopicC))
- (revision-0-5 50)
- (version-1 100))
- (setf *TM-REVISION* version-1)
- (add-theme var-1 scope-1)
- (add-theme var-1 scope-2)
- (is-true (d::equivalent-construct
- var-1 :charvalue "var-1" :datatype constants:*xml-string*
- :themes (list scope-2 scope-1)))
- (is-false (d::equivalent-construct
- var-1 :charvalue "var-1" :datatype constants:*xml-string*
- :themes (list scope-2 scope-1)
- :start-revision revision-0-5))
- (is-false (d::equivalent-construct
- var-1 :charvalue "var-1" :datatype constants:*xml-string*
- :themes (list scope-3 scope-2)))
- (is-false (d::equivalent-construct
- var-1 :charvalue "var-1"
- :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- var-1 :charvalue "var-2" :datatype constants:*xml-string*
- :themes (list scope-2 scope-1))))))
+ (rev-0-5 50)
+ (rev-1 100))
+ (let ((var-1 (make-construct 'VariantC
+ :charvalue "var-1"
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (var-2 (make-construct 'VariantC
+ :charvalue "var-2"
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (var-3 (make-construct 'VariantC
+ :charvalue "var-1"
+ :themes (list scope-1 scope-3)
+ :start-revision rev-1))
+ (var-4 (make-construct 'VariantC
+ :charvalue "var-1"
+ :datatype *xml-uri*
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (var-5 (make-construct 'VariantC
+ :charvalue "var-1"
+ :themes (list scope-1)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-theme var-5 scope-2)
+ (is-true (d::equivalent-construct
+ var-1 :charvalue "var-1" :datatype constants:*xml-string*
+ :themes (list scope-2 scope-1)))
+ (is-false (d::equivalent-construct
+ var-1 :charvalue "var-1" :datatype constants:*xml-string*
+ :themes (list scope-2 scope-1)
+ :start-revision rev-0-5))
+ (is-false (d::equivalent-construct
+ var-1 :charvalue "var-1" :datatype constants:*xml-string*
+ :themes (list scope-3 scope-2)))
+ (is-false (d::equivalent-construct
+ var-1 :charvalue "var-1"
+ :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ var-1 :charvalue "var-2" :datatype constants:*xml-string*
+ :themes (list scope-2 scope-1)))
+ (is-false (d::strictly-equivalent-constructs var-1 var-1))
+ (is-false (d::strictly-equivalent-constructs var-1 var-2))
+ (is-false (d::strictly-equivalent-constructs var-1 var-3))
+ (is-false (d::strictly-equivalent-constructs var-1 var-4))
+ (is-true (d::strictly-equivalent-constructs var-1 var-5))))))
(test test-equivalent-RoleC ()
"Tests the functions equivalent-construct depending on RoleC."
(with-fixture with-empty-db (*db-dir*)
- (let ((role-1 (make-instance 'd:RoleC))
- (type-1 (make-instance 'd:TopicC))
+ (let ((type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
(player-1 (make-instance 'd:TopicC))
(player-2 (make-instance 'd:TopicC))
- (revision-1 100)
- (revision-2 200))
- (setf *TM-REVISION* revision-1)
- (add-type role-1 type-1)
- (add-player role-1 player-1)
- (is-true (d::equivalent-construct role-1 :player player-1
- :instance-of type-1))
- (is-false (d::equivalent-construct role-1 :player player-2
- :instance-of type-1))
- (is-false (d::equivalent-construct role-1 :player player-1
- :instance-of type-2))
- (setf *TM-REVISION* revision-2)
- (delete-player role-1 player-1 :revision revision-2)
- (add-player role-1 player-2)
- (delete-type role-1 type-1 :revision revision-2)
- (add-type role-1 type-2)
- (is-true (d::equivalent-construct role-1 :player player-2
- :instance-of type-2))
- (is-false (d::equivalent-construct role-1 :player player-1
- :instance-of type-2))
- (is-false (d::equivalent-construct role-1 :player player-2
- :instance-of type-1)))))
+ (rev-1 100)
+ (rev-2 200))
+ (let ((role-1 (make-construct 'RoleC
+ :player player-1
+ :instance-of type-1
+ :start-revision rev-1))
+ (role-2 (make-construct 'RoleC
+ :player player-2
+ :instance-of type-1
+ :start-revision rev-1))
+ (role-3 (make-construct 'RoleC
+ :player player-1
+ :instance-of type-2
+ :start-revision rev-1))
+ (role-4 (make-construct 'RoleC
+ :instance-of type-1
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-player role-4 player-1)
+ (is-true (d::equivalent-construct role-1 :player player-1
+ :instance-of type-1))
+ (is-false (d::equivalent-construct role-1 :player player-2
+ :instance-of type-1))
+ (is-false (d::equivalent-construct role-1 :player player-1
+ :instance-of type-2))
+ (is-false (d::strictly-equivalent-constructs role-1 role-1))
+ (is-false (d::strictly-equivalent-constructs role-1 role-2))
+ (is-false (d::strictly-equivalent-constructs role-1 role-3))
+ (is-true (d::strictly-equivalent-constructs role-1 role-4))
+ (setf *TM-REVISION* rev-2)
+ (delete-player role-1 player-1 :revision rev-2)
+ (add-player role-1 player-2)
+ (delete-type role-1 type-1 :revision rev-2)
+ (add-type role-1 type-2)
+ (is-true (d::equivalent-construct role-1 :player player-2
+ :instance-of type-2))
+ (is-false (d::equivalent-construct role-1 :player player-1
+ :instance-of type-2))
+ (is-false (d::equivalent-construct role-1 :player player-2
+ :instance-of type-1))))))
(test test-equivalent-AssociationC ()
@@ -1684,67 +1808,80 @@
(r-type-1 (make-instance 'TopicC))
(r-type-2 (make-instance 'TopicC))
(r-type-3 (make-instance 'TopicC))
- (revision-1 100))
- (let ((assoc-1 (make-instance 'd:AssociationC))
- (role-1 (make-construct 'd:RoleC
- :start-revision revision-1
- :player player-1
- :instance-of r-type-1))
- (role-2 (make-construct 'd:RoleC
- :start-revision revision-1
- :player player-2
- :instance-of r-type-2))
+ (rev-1 100))
+ (let ((role-1 (list :player player-1 :instance-of r-type-1
+ :start-revision rev-1))
+ (role-2 (list :player player-2 :instance-of r-type-2
+ :start-revision rev-1))
+ (role-3 (list :instance-of r-type-3 :player player-3
+ :start-revision rev-1))
(type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
(scope-1 (make-instance 'd:TopicC))
(scope-2 (make-instance 'd:TopicC))
(scope-3 (make-instance 'd:TopicC)))
- (setf *TM-REVISION* revision-1)
- (d:add-role assoc-1 role-1)
- (d:add-role assoc-1 role-2)
- (d:add-type assoc-1 type-1)
- (d:add-theme assoc-1 scope-1)
- (d:add-theme assoc-1 scope-2)
- (is-true (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1
- :start-revision revision-1)
- (list :instance-of r-type-2 :player player-2
- :start-revision revision-1))
- :instance-of type-1 :themes (list scope-1 scope-2)
- :start-revision revision-1))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1)
- (list :instance-of r-type-2 :player player-2)
- (list :instance-of r-type-3 :player player-3))
- :instance-of type-1 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1))
- :instance-of type-1 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1)
- (list :instance-of r-type-3 :player player-3))
- :instance-of type-1 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1)
- (list :instance-of r-type-2 :player player-2))
- :instance-of type-2 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1)
- (list :instance-of r-type-2 :player player-2))
- :instance-of type-2 :themes (list scope-1 scope-3)))))))
+ (let ((assoc-1 (make-construct 'AssociationC
+ :roles (list role-1 role-2)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (assoc-2 (make-construct 'AssociationC
+ :roles (list role-1 role-2 role-3)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (assoc-3 (make-construct 'AssociationC
+ :roles (list role-1 role-3)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (assoc-4 (make-construct 'AssociationC
+ :roles (list role-1 role-2)
+ :instance-of type-2
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (assoc-5 (make-construct 'AssociationC
+ :roles (list role-1 role-2)
+ :instance-of type-1
+ :themes (list scope-1 scope-3)
+ :start-revision rev-1))
+ (assoc-6 (make-construct 'AssociationC
+ :roles (list role-1)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-role assoc-6 (apply #'make-construct 'RoleC role-2))
+ (is-true (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-2)
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-2 role-3)
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1)
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-3)
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-2)
+ :instance-of type-2 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-2)
+ :instance-of type-2 :themes (list scope-1 scope-3)))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-1))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-2))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-3))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-4))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-5))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-6)))))))
(test test-equivalent-TopicC ()
"Tests the functions equivalent-construct depending on TopicC."
(with-fixture with-empty-db (*db-dir*)
- (let ((top-1 (make-instance 'd:TopicC))
- (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
+ (let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
(ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
(sl-1 (make-instance 'd:SubjectLocatorC :uri "sl-1"))
(sl-2 (make-instance 'd:SubjectLocatorC :uri "sl-2"))
@@ -1754,43 +1891,60 @@
:xtm-id "xtm-id-1"))
(tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2"
:xtm-id "xtm-id-2"))
- (revision-1 100))
- (setf *TM-REVISION* revision-1)
- (d:add-item-identifier top-1 ii-1)
- (d:add-locator top-1 sl-1)
- (d:add-psi top-1 psi-1)
- (d:add-topic-identifier top-1 tid-1)
- (is-true (d::equivalent-construct top-1
- :item-identifiers (list ii-1 ii-2)))
- (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)
- :psis (list psi-1 psi-2)
- :item-identifiers (list ii-1 ii-2)))
- (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)))
- (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2)))
- (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1)))
- (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2)))
- (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2)
- :psis (list psi-2)
- :locators (list sl-2))))))
+ (rev-1 100))
+ (let ((top-1 (make-construct 'TopicC
+ :item-identifiers (list ii-1)
+ :locators (list sl-1)
+ :psis (list psi-1)
+ :topic-identifiers (list tid-1)
+ :start-revision rev-1))
+ (top-2 (make-construct 'TopicC
+ :item-identifiers (list ii-2)
+ :locators (list sl-2)
+ :psis (list psi-2)
+ :topic-identifiers (list tid-2)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (is-true (d::equivalent-construct top-1
+ :item-identifiers (list ii-1 ii-2)))
+ (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)
+ :psis (list psi-1 psi-2)
+ :item-identifiers (list ii-1 ii-2)))
+ (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)))
+ (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2)))
+ (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1)))
+ (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2)))
+ (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2)
+ :psis (list psi-2)
+ :locators (list sl-2)))
+ (is-false (d::strictly-equivalent-constructs top-1 top-1))
+ (is-false (d::strictly-equivalent-constructs top-1 top-2))))))
(test test-equivalent-TopicMapC ()
"Tests the functions equivalent-construct depending on TopicMapC."
(with-fixture with-empty-db (*db-dir*)
- (let ((tm-1 (make-instance 'd:TopicMapC))
- (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
+ (let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
(ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
(reifier-1 (make-instance 'd:TopicC))
(reifier-2 (make-instance 'd:TopicC))
- (revision-1 100))
- (setf *TM-REVISION* revision-1)
- (d:add-item-identifier tm-1 ii-1)
- (d:add-reifier tm-1 reifier-1)
- (is-true (d::equivalent-construct tm-1
- :item-identifiers (list ii-1 ii-2)))
- (is-true (d::equivalent-construct tm-1 :reifier reifier-1))
- (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2)))
- (is-false (d::equivalent-construct tm-1 :reifier reifier-2)))))
+ (rev-1 100))
+ (let ((tm-1 (make-construct 'TopicMapC
+ :item-identifiers (list ii-1)
+ :reifier reifier-1
+ :start-revision rev-1))
+ (tm-2 (make-construct 'TopicMapC
+ :item-identifiers (list ii-2)
+ :reifier reifier-2
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (is-true (d::equivalent-construct tm-1
+ :item-identifiers (list ii-1 ii-2)))
+ (is-true (d::equivalent-construct tm-1 :reifier reifier-1))
+ (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2)))
+ (is-false (d::equivalent-construct tm-1 :reifier reifier-2))
+ (is-false (d::strictly-equivalent-constructs tm-1 tm-1))
+ (is-false (d::strictly-equivalent-constructs tm-1 tm-2))))))
(test test-class-p ()
@@ -2566,6 +2720,58 @@
(is (eql (first (occurrences top-3)) occ-1))))))))
+(test test-find-oldest-construct ()
+ "Tests the generic find-oldest-construct."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((top-1 (make-instance 'TopicC))
+ (top-2 (make-instance 'TopicC))
+ (tm-1 (make-instance 'TopicMapC))
+ (tm-2 (make-instance 'TopicMapC))
+ (assoc-1 (make-instance 'AssociationC))
+ (assoc-2 (make-instance 'AssociationC))
+ (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
+ (variant-1 (make-instance 'VariantC))
+ (variant-2 (make-instance 'VariantC))
+ (name-1 (make-instance 'NameC))
+ (name-2 (make-instance 'NameC))
+ (role-1 (make-instance 'RoleC))
+ (role-2 (make-instance 'RoleC))
+ (rev-1 100)
+ (rev-2 200)
+ (rev-3 300))
+ (setf *TM-REVISION* rev-1)
+ (is-false (d::find-oldest-construct ii-1 ii-2))
+ (add-item-identifier top-1 ii-1 :revision rev-3)
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+ (add-item-identifier assoc-1 ii-2 :revision rev-2)
+ (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
+ (add-item-identifier top-2 ii-1 :revision rev-1)
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+ (is-false (d::find-oldest-construct variant-1 variant-2))
+ (add-variant name-1 variant-1 :revision rev-3)
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+ (add-variant name-1 variant-2 :revision rev-2)
+ (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2)))
+ (add-variant name-2 variant-1 :revision rev-1)
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+ (is-false (d::find-oldest-construct role-1 role-2))
+ (add-role assoc-1 role-1 :revision rev-3)
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
+ (add-role assoc-1 role-2 :revision rev-2)
+ (is (eql role-2 (d::find-oldest-construct role-1 role-2)))
+ (add-role assoc-2 role-1 :revision rev-1)
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
+ (is-false (d::find-oldest-construct tm-1 tm-2))
+ (d::add-to-version-history tm-1 :start-revision rev-3)
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+ (d::add-to-version-history tm-2 :start-revision rev-1)
+ (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2)))
+ (d::add-to-version-history tm-1 :start-revision rev-1)
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+ (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))
+
+
(defun run-datamodel-tests()
@@ -2623,4 +2829,5 @@
(it.bese.fiveam:run! 'test-make-TopicMapC)
(it.bese.fiveam:run! 'test-make-AssociationC)
(it.bese.fiveam:run! 'test-make-TopicC)
+ (it.bese.fiveam:run! 'test-find-oldest-construct)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list