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