Author: lgiessmann Date: Thu Apr 29 11:07:06 2010 New Revision: 292 Log: new-datamodel: fixed two bugs in "merge-constructs" corresponding to "AssociationC" 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 29 11:07:06 2010 @@ -4149,8 +4149,15 @@ (let ((newer-assoc (if (eql older-assoc construct-1) construct-2 construct-1))) - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) + ;(unless (strictly-equivalent-constructs construct-1 construct-2 + ; :revision revision) + ;;associations that have different roles can be although merged, e.g. + ;;two roles are in two different association objects references + ;;the same item-identifier or reifier + (when (or (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision)) + (not (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)))) (error (make-condition 'not-mergable-error :message (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) @@ -4158,6 +4165,8 @@ :construct-2 construct-2))) (dolist (tm (in-topicmaps newer-assoc :revision revision)) (add-to-tm tm older-assoc)) + (delete-type newer-assoc (instance-of newer-assoc :revision revision) + :revision revision) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -4165,10 +4174,14 @@ (strictly-equivalent-constructs older-role newer-role :revision revision)) (roles older-assoc :revision revision)))) - (move-referenced-constructs newer-role equivalent-role - :revision revision) + (when equivalent-role + (move-referenced-constructs newer-role equivalent-role + :revision revision)) (delete-role newer-assoc newer-role :revision revision) - (add-role older-assoc equivalent-role :revision revision))) + (add-role older-assoc (if equivalent-role + equivalent-role + newer-role) + :revision revision))) (mark-as-deleted newer-assoc :revision revision) (when (exist-in-version-history-p newer-assoc) (delete-construct newer-assoc)) 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 29 11:07:06 2010 @@ -90,7 +90,8 @@ :test-merge-constructs-TopicC-7 :test-merge-constructs-TopicC-8 :test-merge-constructs-TopicC-9 - :test-merge-constructs-TopicC-10)) + :test-merge-constructs-TopicC-10 + :test-merge-constructs-AssociationC)) (declaim (optimize (debug 3))) @@ -2938,7 +2939,7 @@ (test test-merge-constructs-TopicC-1 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3051,7 +3052,7 @@ (test test-merge-constructs-TopicC-2 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3165,7 +3166,7 @@ (test test-merge-constructs-TopicC-3 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3265,7 +3266,7 @@ (test test-merge-constructs-TopicC-4 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3323,7 +3324,7 @@ (test test-merge-constructs-TopicC-5 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3381,7 +3382,7 @@ (test test-merge-constructs-TopicC-6 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3452,7 +3453,7 @@ (test test-merge-constructs-TopicC-7 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3521,7 +3522,7 @@ (test test-merge-constructs-TopicC-8 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3587,7 +3588,7 @@ (test test-merge-constructs-TopicC-9 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3641,7 +3642,7 @@ (test test-merge-constructs-TopicC-10 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3716,12 +3717,82 @@ (is-false (set-exclusive-or (list variant-1) (variants name-1))) (is-false (set-exclusive-or (list variant-2) (variants name-4))) (is (= (length (d::versions top-1)) 2)))))))) - - - -;;TODO: merge associations caused by a merge of their roles +(test test-merge-constructs-AssociationC () + "Tests merge-constructs corresponding to AssociationC." + (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)) + (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"))) + (let ((role-1 (list :start-revision rev-1 + :player player-1 + :instance-of r-type-1)) + (role-2-1 (list :start-revision rev-1 + :player player-1 + :instance-of r-type-2)) + (role-2-2 (list :start-revision rev-2 + :player player-1 + :item-identifiers (list ii-2) + :instance-of r-type-2)) + (role-3 (list :start-revision rev-2 + :player player-2 + :instance-of r-type-1 + :item-identifiers (list ii-1) + :instance-of r-type-2))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :roles (list role-1 role-2-1))) + (assoc-2 (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-1 + :roles (list role-2-2 role-3)))) + (setf *TM-REVISION* rev-3) + (is (= (length (get-all-associations nil)) 2)) + (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-1 + :roles (list role-1 role-2-1)) + (is (= (length (get-all-associations nil)) 2)) + (let ((role-2-1-inst + (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-2) + (eql (player role) player-1))) + (roles assoc-1)))) + (is-true role-2-1-inst) + (is (eql (add-item-identifier role-2-1-inst ii-2) role-2-1-inst)) + (is-true (marked-as-deleted-p assoc-2)) + (is-false (roles assoc-2)) + (is-false (instance-of assoc-2)) + (is-false (themes assoc-2)) + (is (eql (instance-of assoc-2 :revision rev-2) type-1)) + (is (= (length (roles assoc-1)) 3)) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-1) + (eql (player role) player-1))) + (roles assoc-1))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-1) + (eql (player role) player-2) + (not (set-exclusive-or + (list ii-1) + (item-identifiers role))))) + (roles assoc-1))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-2) + (eql (player role) player-1) + (not (set-exclusive-or + (list ii-2) + (item-identifiers role))))) + (roles assoc-1)))))))))) (defun run-datamodel-tests() @@ -3792,4 +3863,4 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10) - ) \ No newline at end of file + (it.bese.fiveam:run! 'test-merge-constructs-AssociationC)) \ No newline at end of file