[isidorus-cvs] r292 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Apr 29 15:07:07 UTC 2010
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
More information about the Isidorus-cvs
mailing list