Author: lgiessmann Date: Fri Apr 23 14:47:37 2010 New Revision: 286 Log: new-datamodel: fixed an elephant bug that appears in the current version --> "get-instances-by-class" is embraced within a function that filters all instances by typep and optional a given revision; fixed a potential versioning bug in "merge-all-constructs"; fixed a bug in "equivalent-construct" --> AssociationC; fixed a bug in "merge-changed-constructs"; fixed a bug in "merge-constructs" --> the returned association object is added to the union of all tms the given associations were present in; added some unit-tests 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 Fri Apr 23 14:47:37 2010 @@ -148,6 +148,9 @@ :check-for-duplicate-identifiers :find-item-by-content :rec-remf + :get-all-topics + :get-all-associations + :get-all-tms ;;globals :*TM-REVISION* @@ -156,10 +159,10 @@ (in-package :datamodel) - -;;TODO: mark-as-deleted should call mark-as-deleted for every owned ??? -;; versioned-construct of the called construct, same for add-xy ??? -;; and associations of player +;;TODO: replace add-<xy> + add-parent in all merge-constructs where the +;; characteristics are readded to make sure they are added to the current +;; version --> collidates with merge-if-equivalent!!! in merge-constructs +;;TODO: adapt changes-lisp ;;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), @@ -701,6 +704,34 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*)) + "Returns all instances of the given type and the given revision that are + stored in the db." + (declare (symbol class-symbol) (type (or null integer) revision)) + (let ((db-instances (elephant:get-instances-by-class class-symbol))) + (let ((filtered-instances (remove-if-not #'(lambda(inst) + (typep inst class-symbol)) + db-instances))) + (if revision + (remove-if #'null + (map 'list #'(lambda(inst) + (find-item-by-revision inst revision)) + filtered-instances)) + filtered-instances)))) + + +(defun get-all-topics (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicC :revision revision)) + + +(defun get-all-associations (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'AssociationC :revision revision)) + + +(defun get-all-tms (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicMapC :revision revision)) + + (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 @@ -811,14 +842,15 @@ (condition () nil))) -(defun merge-all-constructs(constructs-to-be-merged) +(defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*)) "Merges all constructs contained in the given list." (declare (list constructs-to-be-merged)) (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1)) (merged-construct (elt constructs-to-be-merged 0))) (loop for construct-to-be-merged in constructs-to-be-merged do (setf merged-construct - (merge-constructs merged-construct construct-to-be-merged))))) + (merge-constructs merged-construct construct-to-be-merged + :revision revision))))) (defgeneric internal-id (construct) @@ -980,7 +1012,7 @@ ;;; VersionedConstructC -(defgeneric exist-in-revision-history-? (versioned-construct) +(defgeneric exist-in-version-history-p (versioned-construct) (:documentation "Returns t if the passed construct does not exist in any revision, i.e. the construct has no version-infos or exactly one whose start-revision is equal to its end-revision.") @@ -1106,8 +1138,16 @@ (let ((last-version ;the last active version (find 0 (versions construct) :key #'end-revision))) - (when last-version - (setf (end-revision last-version) revision)))) + (if (and last-version + (= (start-revision last-version) revision)) + (progn + (delete-construct last-version) + (let ((sorted-versions + (sort (versions construct) #'> :key #'end-revision))) + (when sorted-versions + (setf (end-revision (first sorted-versions)) revision)))) + (when last-version + (setf (end-revision last-version) revision))))) ;;; TopicMapconstructC @@ -2494,9 +2534,14 @@ (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))))) + (themes construct-2 :revision revision))) + + (not (set-exclusive-or + (roles construct-1 :revision revision) + (roles construct-2 :revision revision) + :test #'(lambda(role-1 role-2) + (strictly-equivalent-constructs role-1 role-2 + :revision revision)))))) (defgeneric AssociationC-p (class-symbol) @@ -2517,21 +2562,22 @@ (type (or null TopicC) instance-of)) ;; item-identifiers and reifers are not checked because the equality have to ;; be variafied without them - (let ((checked-roles - (loop for assoc-role in (roles construct :revision start-revision) - when (loop for plist in roles - when (equivalent-construct - assoc-role :player (getf plist :player) - :start-revision (or (getf plist :start-revision) - start-revision) - :instance-of (getf plist :instance-of)) - return t) - collect assoc-role))) + (let ((checked-roles nil)) + (loop for plist in roles + do (let ((found-role + (find-if #'(lambda(assoc-role) + (equivalent-construct + assoc-role :player (getf plist :player) + :start-revision (or (getf plist :start-revision) + start-revision) + :instance-of (getf plist :instance-of))) + (roles construct :revision start-revision)))) + (when found-role + (push found-role checked-roles)))) (and (not (set-exclusive-or (roles construct :revision start-revision) checked-roles)) - (= (length (roles construct :revision start-revision)) - (length roles)) + (= (length checked-roles) (length roles)) (equivalent-typable-construct construct instance-of :start-revision start-revision) (equivalent-scopable-construct construct themes @@ -3428,9 +3474,10 @@ :roles roles :themes themes :instance-of instance-of) existing-association)) - (elephant:get-instances-by-class 'AssociationC))))) + (get-all-associations nil))))) (cond ((> (length existing-associations) 1) - (merge-all-constructs existing-associations)) + (merge-all-constructs existing-associations + :revision start-revision)) (existing-associations (first existing-associations)) (t @@ -3512,9 +3559,9 @@ :item-identifiers item-identifiers :reifier reifier) existing-tm)) - (elephant:get-instances-by-class 'TopicMapC))))) + (get-all-tms start-revision))))) (cond ((> (length existing-tms) 1) - (merge-all-constructs existing-tms)) + (merge-all-constructs existing-tms :revision start-revision)) (existing-tms (first existing-tms)) (t @@ -3554,9 +3601,9 @@ :item-identifiers item-identifiers :topic-identifiers topic-identifiers) existing-topic)) - (elephant:get-instances-by-class 'TopicC))))) + (get-all-topics start-revision))))) (cond ((> (length existing-topics) 1) - (merge-all-constructs existing-topics)) + (merge-all-constructs existing-topics :revision start-revision)) (existing-topics (first existing-topics)) (t @@ -3919,23 +3966,61 @@ (let ((parent (when (or (typep construct 'RoleC) (typep construct 'CharacteristicC)) (parent construct :revision revision)))) - (let ((found-equivalent - (find-if #'(lambda(other-construct) - (strictly-equivalent-constructs - other-construct construct :revision revision)) - (cond ((typep construct 'OccurrenceC) - (occurrences parent :revision revision)) - ((typep construct 'NameC) - (names parent :revision revision)) - ((typep construct 'VariantC) - (variants parent :revision revision)) - ((typep construct 'RoleC) - (roles parent :revision revision)) - ((typep construct 'AssociationC) - (elephant:get-instances-by-class 'AssociationC)))))) - (when found-equivalent - (merge-all-constructs (append found-equivalent (list construct)))))))) - + (let ((all-other (cond ((typep construct 'OccurrenceC) + (occurrences parent :revision revision)) + ((typep construct 'NameC) + (names parent :revision revision)) + ((typep construct 'VariantC) + (variants parent :revision revision)) + ((typep construct 'RoleC) + (roles parent :revision revision))))) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(other) + (when (strictly-equivalent-constructs + construct other :revision revision) + other)) + all-other)))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list construct)) + :revision revision)))))) + (merge-changed-associations older-topic :revision revision)) + + +(defun merge-changed-associations (older-topic &key (revision *TM-REVISION*)) + "Merges all associations that became TMDM-equal since two referenced topics + were merged, e.g. the association types." + (declare (TopicC older-topic)) + (let ((all-assocs + (remove-duplicates + (append + (remove-if + #'null + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles older-topic :revision revision))) + (remove-if + #'null + (map + 'list #'(lambda(constr) + (when (typep constr 'AssociationC) + constr)) + (append (used-as-type older-topic :revision revision) + (used-as-theme older-topic :revision revision)))))))) + (dolist (assoc all-assocs) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(db-assoc) + (when (strictly-equivalent-constructs + assoc db-assoc :revision revision) + db-assoc)) + (get-all-associations nil))))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list assoc)) + :revision revision)))))) + (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) @@ -3953,7 +4038,7 @@ (move-reified-construct newer-topic older-topic :revision revision) (merge-changed-constructs older-topic :revision revision) (mark-as-deleted newer-topic :revision revision :source-locator nil) - (when (exist-in-revision-history-? newer-topic) + (when (exist-in-version-history-p newer-topic) (delete-construct newer-topic)) older-topic)))) @@ -3980,7 +4065,7 @@ (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-char older-char :revision revision) - (delete-characteristic newer-char parent-2 + (delete-characteristic parent-2 newer-char :revision revision) older-char) ((and parent-1 parent-2) @@ -4032,7 +4117,7 @@ (add-to-tm top-or-assoc top-or-assoc)) (add-to-version-history older-tm :start-revision revision) (mark-as-deleted newer-tm :revision revision) - (when (exist-in-revision-history-? newer-tm) + (when (exist-in-version-history-p newer-tm) (delete-construct newer-tm)) older-tm)))) @@ -4053,6 +4138,8 @@ construct-1 construct-2) :construct-1 construct-1 :construct-2 construct-2))) + (dolist (tm (in-topicmaps newer-assoc :revision revision)) + (add-to-tm tm older-assoc)) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -4065,7 +4152,7 @@ (delete-role newer-assoc newer-role :revision revision) (add-role older-assoc equivalent-role :revision revision))) (mark-as-deleted newer-assoc :revision revision) - (when (exist-in-revision-history-? newer-assoc) + (when (exist-in-version-history-p newer-assoc) (delete-construct newer-assoc)) older-assoc)))) @@ -4091,8 +4178,14 @@ (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-role older-role :revision revision) - (delete-role newer-role parent-2 :revision revision) - (add-role older-role parent-1 :revision revision)) + (delete-role parent-2 newer-role :revision revision) + (let ((r-assoc + (find-if + #'(lambda(r-assoc) + (and (eql (role r-assoc) older-role) + (eql (parent-construct r-assoc) parent-1))) + (slot-p parent-1 'roles)))) + (add-to-version-history r-assoc :start-revision revision))) ((and parent-1 parent-2) (let ((active-assoc (merge-constructs parent-1 parent-2 :revision revision))) 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 Fri Apr 23 14:47:37 2010 @@ -81,7 +81,12 @@ :test-find-oldest-construct :test-move-referenced-constructs-ReifiableConstructC :test-move-referenced-constructs-NameC - :test-merge-constructs-TopicC-1)) + :test-merge-constructs-TopicC-1 + :test-merge-constructs-TopicC-2 + :test-merge-constructs-TopicC-3 + :test-merge-constructs-TopicC-4 + :test-merge-constructs-TopicC-5 + :test-merge-constructs-TopicC-6)) ;;TODO: test merge-constructs @@ -1815,7 +1820,7 @@ :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 + (role-3 (list :player player-3 :instance-of r-type-3 :start-revision rev-1)) (type-1 (make-instance 'd:TopicC)) (type-2 (make-instance 'd:TopicC)) @@ -1877,7 +1882,7 @@ (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))))))) + (is-true (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) (test test-equivalent-TopicC () @@ -3046,6 +3051,414 @@ (is-true (d::marked-as-deleted-p occ-3)))))))))) +(test test-merge-constructs-TopicC-2 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-1")) + (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2" + :xtm-id "xtm-2")) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (variant-2 (make-construct 'VariantC + :start-revision rev-2 + :charvalue "var-2" + :themes (list theme-2))) + (variant-3 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1))) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-2" + :instance-of type-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-2 + :item-identifiers (list ii-3) + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1)))) + (let ((name-1 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1)) + (name-2 (make-construct 'NameC + :start-revision rev-2 + :charvalue "name-2" + :instance-of type-1 + :variants (list variant-1 variant-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1 + :variants (list variant-3)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :topic-identifiers (list tid-1) + :item-identifiers (list ii-1) + :locators (list sl-1) + :psis (list psi-1) + :names (list name-1 name-2) + :occurrences (list occ-1 occ-2))) + (top-2 (make-construct 'TopicC + :start-revision rev-3 + :topic-identifiers (list tid-2) + :item-identifiers (list ii-2) + :locators (list sl-2) + :psis (list psi-2) + :names (list name-3) + :occurrences (list occ-3)))) + (setf *TM-REVISION* rev-3) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 6)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 3)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (let ((top (d::merge-constructs top-1 top-2 :revision rev-3))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (is (eql top top-1)) + (is-false (append (psis top-2) (item-identifiers top-2) + (locators top-2) (topic-identifiers top-2) + (names top-2) (occurrences top-2))) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers top-1))) + (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1))) + (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) + (is-false (set-exclusive-or (list tid-1 tid-2) + (topic-identifiers top-1))) + (is-false (set-exclusive-or (list psi-1) + (psis top-1 :revision rev-2))) + (is-false (set-exclusive-or (list name-1 name-2) + (names top-1))) + (is-false (set-exclusive-or (variants name-1) + (list variant-3))) + (is-false (variants name-3)) + (is-false (set-exclusive-or (occurrences top-1) + (list occ-1 occ-2))) + (is-false (set-exclusive-or (item-identifiers occ-1) + (list ii-3))) + (is-false (item-identifiers occ-3)) + (is-true (d::marked-as-deleted-p name-3)) + (is-true (d::marked-as-deleted-p occ-3)))))))))) + + +(test test-merge-constructs-TopicC-3 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (n-type (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")) + (ii-5 (make-construct 'ItemIdentifierC :uri "ii-5")) + (ii-6 (make-construct 'ItemIdentifierC :uri "ii-6")) + (var-0-1 + (make-construct 'VariantC + :start-revision rev-1 + :themes (list + (make-construct 'TopicC + :start-revision rev-1)) + :charvalue "var-0-1")) + (var-0-2 + (make-construct 'VariantC + :start-revision rev-1 + :themes (list + (make-construct 'TopicC + :start-revision rev-1)) + :charvalue "var-0-1"))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-1) + :charvalue "occ" + :instance-of type-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-2) + :charvalue "occ" + :instance-of type-2)) + (name-1 (make-construct 'NameC + :start-revision rev-1 + :item-identifiers (list ii-3) + :variants (list var-0-1) + :charvalue "name" + :instance-of type-1)) + (name-2 (make-construct 'NameC + :start-revision rev-1 + :item-identifiers (list ii-4) + :variants (list var-0-2) + :charvalue "name" + :instance-of type-2)) + (var-1 (make-construct 'VariantC + :start-revision rev-1 + :item-identifiers (list ii-5) + :charvalue "var" + :themes (list type-1))) + (var-2 (make-construct 'VariantC + :start-revision rev-1 + :item-identifiers (list ii-6) + :charvalue "var" + :themes (list type-2)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :occurrences (list occ-1 occ-2) + :names (list name-1 name-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3" + :instance-of n-type + :variants (list var-1 var-2)))) + (let ((top-2 (make-construct 'TopicC + :start-revision rev-1 + :names (list name-3)))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (occurrences top-1)) 1)) + (is-false (set-exclusive-or + (list ii-1 ii-2) + (item-identifiers (first (occurrences top-1))))) + (is (= (length (slot-value top-1 'd::occurrences)) 2)) + (is (= (length (names top-1)) 1)) + (is-false (set-exclusive-or + (list ii-3 ii-4) + (item-identifiers (first (names top-1))))) + (is (= (length (slot-value top-1 'd::names)) 2)) + (is-false (set-exclusive-or (list var-0-1 var-0-2) + (variants (first (names top-1))))) + (is-true (d::marked-as-deleted-p + (find-if-not #'(lambda(occ) + (eql occ (first (occurrences top-1)))) + (slot-value top-1 'd::occurrences)))) + (is-true (d::marked-as-deleted-p + (find-if-not #'(lambda(name) + (eql name (first (names top-1)))) + (slot-value top-1 'd::names)))) + (is (= (length (variants (first (names top-2)))) 1)) + (is (= (length (slot-value (first (names top-2)) 'd::variants)) 2)) + (is (eql (first (themes (first (variants (first (names top-2)))))) + type-1))))))))) + + +(test test-merge-constructs-TopicC-4 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (a-type (make-construct 'TopicC :start-revision rev-1)) + (r-type (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of a-type + :roles (list (list :player type-1 + :instance-of r-type + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player type-2 + :item-identifiers (list ii-2) + :instance-of r-type + :start-revision rev-1))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (roles assoc-1)) 1)) + (is (= (length (slot-value assoc-1 'd::roles)) 2)) + (is (eql (instance-of (first (roles assoc-1))) r-type)) + (is (eql (player (first (roles assoc-1))) type-1)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers (first (roles assoc-1))))) + (let ((active-role (first (roles assoc-1))) + (non-active-role + (let ((r-assoc (find-if-not #'(lambda(role) + (eql role (first (roles assoc-1)))) + (slot-value assoc-1 'd::roles)))) + (when r-assoc + (d::role r-assoc))))) + (is (= (length (d::versions + (first (slot-value active-role 'd::parent)))) 2)) + (is (= (length (d::versions + (first (slot-value non-active-role 'd::parent)))) 1)) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value non-active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-3 (d::start-revision vi)) + (= 0 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))))))))) + + +(test test-merge-constructs-TopicC-5 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (a-type (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((assoc-2 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of a-type + :roles (list (list :player player-1 + :instance-of type-1 + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player player-1 + :item-identifiers (list ii-2) + :instance-of type-2 + :start-revision rev-1))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (roles assoc-2)) 1)) + (is (= (length (slot-value assoc-2 'd::roles)) 2)) + (is (eql (instance-of (first (roles assoc-2))) type-1)) + (is (eql (player (first (roles assoc-2))) player-1)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers (first (roles assoc-2))))) + (let ((active-role (first (roles assoc-2))) + (non-active-role + (let ((r-assoc (find-if-not #'(lambda(role) + (eql role (first (roles assoc-2)))) + (slot-value assoc-2 'd::roles)))) + (when r-assoc + (d::role r-assoc))))) + (is (= (length (d::versions + (first (slot-value active-role 'd::parent)))) 2)) + (is (= (length (d::versions + (first (slot-value non-active-role 'd::parent)))) 1)) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value non-active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-3 (d::start-revision vi)) + (= 0 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))))))))) + + +(test test-merge-constructs-TopicC-6 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (r-type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-2 (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (player-2 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))) + (let ((assoc-3 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :item-identifiers (list ii-3) + :roles (list (list :player player-1 + :instance-of r-type-1 + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player player-2 + :instance-of r-type-2 + :start-revision rev-1)))) + (assoc-4 (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-2 + :item-identifiers (list ii-4) + :roles (list (list :player player-1 + :instance-of r-type-1 + :start-revision rev-2) + (list :player player-2 + :item-identifiers (list ii-2) + :instance-of r-type-2 + :start-revision rev-2))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (d::versions assoc-3)) 2)) + (is (= (length (d::versions assoc-4)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-1) + (= (d::end-revision vi) rev-3))) + (d::versions assoc-3))) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-3) + (= (d::end-revision vi) 0))) + (d::versions assoc-3))) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-2) + (= (d::end-revision vi) rev-3))) + (d::versions assoc-4))) + (is (= (length (roles assoc-3)) 2)) + (is (= (length (item-identifiers (first (roles assoc-3)))) 1)) + (is (= (length (item-identifiers (second (roles assoc-3)))) 1)) + (is (or (and (string= (uri (first (item-identifiers + (first (roles assoc-3))))) + "ii-1") + (string= (uri (first (item-identifiers + (second (roles assoc-3))))) + "ii-2")) + (and (string= (uri (first (item-identifiers + (first (roles assoc-3))))) + "ii-2") + (string= (uri (first (item-identifiers + (second (roles assoc-3))))) + "ii-1"))))))))) + + + + + + +;;TODO: merge topics/associations caused by a merge of their characteristics +;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified +;; by the same reifier @@ -3108,4 +3521,9 @@ (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-2) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-3) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) ) \ No newline at end of file