Author: lgiessmann Date: Wed Mar 24 12:37:21 2010 New Revision: 252
Log: new-datamodel: added unit-tests for "make-construct" --> "AssociationC"; fixed a bug in "make-association" and "equivalent-construct" --> "AssociationC"; changed the general concept of creating associations
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 Wed Mar 24 12:37:21 2010 @@ -1987,17 +1987,33 @@ &key (start-revision *TM-REVISION*) (roles nil) (instance-of nil) (themes nil)) "Associations are equal if their themes, instance-of and roles - properties are equal." + properties are equal. + To avoid ceation of duplicate roles the parameter roles is a list of plists + of the form: ((:player <TopicC> :instance-of <TopicC> + :item-identifiers <(ItemIdentifierC)> :reifier <TopicC>))." (declare (integer start-revision) (list roles themes) (type (or null TopicC) instance-of)) ;; item-identifiers and reifers are not checked because the equality have to ;; be variafied without them - (and - (not (set-exclusive-or roles (roles construct :revision start-revision))) - (equivalent-typable-construct construct instance-of - :start-revision start-revision) - (equivalent-scopable-construct construct themes - :start-revision start-revision))) + (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))) + (and + (not (set-exclusive-or (roles construct :revision start-revision) + checked-roles)) + (= (length (roles construct :revision start-revision)) + (length roles)) + (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (equivalent-scopable-construct construct themes + :start-revision start-revision))))
(defmethod delete-construct :before ((construct AssociationC)) @@ -2730,6 +2746,9 @@ :start-revision start-revision)) (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision start-revision)) + (when (or (typep construct 'TopicC) (typep construct 'AssociationC)) + (dolist (tm (getf args :in-topicmaps)) + (add-to-tm tm construct))) (if (typep construct 'ReifiableConstructC) (complete-reifiable construct (getf args :item-identifiers) (getf args :reifier) :start-revision start-revision) @@ -2742,8 +2761,8 @@ This function exists only for being used by make-construct!" (let ((instance-of (getf args :instance-of)) (start-revision (getf args :start-revision)) - (themes (get args :themes)) - (roles (get args :roles))) + (themes (getf args :themes)) + (roles (getf args :roles))) (when (and (or roles instance-of themes) (not start-revision)) (error "From make-association(): start-revision must be set")) @@ -2760,10 +2779,14 @@ existing-association)) (elephant:get-instances-by-class 'AssociationC))))) (if existing-association - existing-association + (first existing-association) (make-instance 'AssociationC))))) - (dolist (role roles) - (add-role association role :revision start-revision)) + (dolist (role-plist roles) + (add-role association + (apply #'make-construct 'RoleC + (append role-plist (list :parent association))) + :revision (getf role-plist :start-revision))) + (format t "~%~%~%") association)))
@@ -2786,12 +2809,13 @@ (map 'list #'(lambda(existing-role) (when (equivalent-construct existing-role + :start-revision start-revision :player player :instance-of instance-of) existing-role)) - (slot-p parent 'roles)))))) + (map 'list #'role (slot-p parent 'roles))))))) (if existing-role - existing-role + (first existing-role) (make-instance 'RoleC))))) (when player (add-player role player :revision start-revision)) @@ -2914,7 +2938,7 @@ existing-characteristic)) (get-all-characteristics parent class-symbol)))))) (if existing-characteristic - existing-characteristic + (first existing-characteristic) (make-instance class-symbol :charvalue charvalue :datatype datatype))))) (when (typep characteristic 'NameC)
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 Wed Mar 24 12:37:21 2010 @@ -70,7 +70,8 @@ :test-make-NameC :test-make-VariantC :test-make-RoleC - :test-make-TopicMapC)) + :test-make-TopicMapC + :test-make-AssociationC))
;;TODO: test make-construct @@ -619,6 +620,7 @@ (version-1 100) (version-2 200) (version-3 300)) + (setf *TM-REVISION* version-1) (is-false (reifier reified-rc)) (is-false (reified-construct reifier-top)) (add-reifier reified-rc reifier-top :revision version-1) @@ -1125,7 +1127,7 @@ (name-2 (make-instance 'NameC)) (revision-1 100) (revision-2 200)) - (setf *TM-REVISION* 100) + (setf *TM-REVISION* revision-1) (add-item-identifier occ-1 ii-1 :revision revision-1) (add-item-identifier occ-1 ii-2 :revision revision-2) (delete-item-identifier occ-1 ii-1 :revision revision-2) @@ -1173,7 +1175,7 @@ (topic-4 (make-instance 'TopicC)) (revision-1 100) (revision-2 200)) - (setf *TM-REVISION* 100) + (setf *TM-REVISION* revision-1) (add-psi topic-1 psi-1 :revision revision-1) (add-psi topic-1 psi-2 :revision revision-2) (delete-psi topic-1 psi-1 :revision revision-2) @@ -1218,7 +1220,7 @@ (topic-4 (make-instance 'TopicC)) (revision-1 100) (revision-2 200)) - (setf *TM-REVISION* 100) + (setf *TM-REVISION* revision-1) (add-locator topic-1 sl-1 :revision revision-1) (add-locator topic-1 sl-2 :revision revision-2) (delete-locator topic-1 sl-1 :revision revision-2) @@ -1675,34 +1677,66 @@ (test test-equivalent-AssociationC () "Tests the functions equivalent-construct depending on AssociationC." (with-fixture with-empty-db (*db-dir*) - (let ((assoc-1 (make-instance 'd:AssociationC)) - (role-1 (make-instance 'd:RoleC)) - (role-2 (make-instance 'd:RoleC)) - (role-3 (make-instance 'd:RoleC)) - (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)) + (let ((player-1 (make-instance 'TopicC)) + (player-2 (make-instance 'TopicC)) + (player-3 (make-instance 'TopicC)) + (r-type-1 (make-instance 'TopicC)) + (r-type-2 (make-instance 'TopicC)) + (r-type-3 (make-instance 'TopicC)) (revision-1 100)) - (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 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 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-1 - :themes (list scope-1 scope-3 scope-2)))))) + (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)) + (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)))))))
(test test-equivalent-TopicC () @@ -1888,11 +1922,10 @@ (test test-make-Unknown () "Tests the function make-construct corresponding to an unknown class." (defclass Unknown () - ((value :initarg :value - :accessor value))) + ((value :initarg :value))) (let ((construct (make-construct 'Unknown :value "value"))) (is-true construct) - (is (string= (value construct) "value")))) + (is (string= (slot-value construct 'value) "value"))))
(test test-make-VersionedConstructC () @@ -1903,6 +1936,7 @@ (rev-0 0) (rev-1 100) (rev-2 200)) + (setf *TM-REVISION* rev-1) (let ((vc (make-construct 'VersionedConstructC :start-revision rev-2)) (psi-assoc (make-construct 'd::PersistentIdAssociationC @@ -1912,6 +1946,7 @@ (signals error (make-construct 'd::PersistentIdAssociationC :start-revision rev-1 :identifier psi-1)) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'VersionedConstructC)) (is (= (length (d::versions vc)) 1)) (is-true (find-if #'(lambda(vi) @@ -1942,6 +1977,9 @@ :uri "uri")) (signals error (make-construct 'TopicIdentificationC :xtm-id "xtm-id")) + (setf *TM-REVISION* rev-1) + (signals error (make-construct 'TopicIdentificationC :uri "uri" + :identified-construct top-1)) (is (string= (uri tid-1) "tid-1")) (is (string= (xtm-id tid-1) "xtm-id-1")) (is-false (d::slot-p tid-1 'd::identified-construct)) @@ -1975,7 +2013,10 @@ :uri "psi-2" :identified-construct top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'PersistentIdC)) + (signals error (make-construct 'PersistentIdC :uri "uri" + :identified-construct top-1)) (is (string= (uri psi-1) "psi-1")) (is-false (d::slot-p psi-1 'd::identified-construct)) (is (string= (uri psi-2) "psi-2")) @@ -2007,7 +2048,10 @@ :uri "sl-2" :identified-construct top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'SubjectLocatorC)) + (signals error (make-construct 'SubjectLocatorC :uri "uri" + :identified-construct top-1)) (is (string= (uri sl-1) "sl-1")) (is-false (d::slot-p sl-1 'd::identified-construct)) (is (string= (uri sl-2) "sl-2")) @@ -2039,7 +2083,10 @@ :uri "ii-2" :identified-construct top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'ItemIdentifierC)) + (signals error (make-construct 'ItemIdentifierC :uri "uri" + :identified-construct top-1)) (is (string= (uri ii-1) "ii-1")) (is-false (d::slot-p ii-1 'd::identified-construct)) (is (string= (uri ii-2) "ii-2")) @@ -2085,6 +2132,7 @@ :charvalue "charvalue-2" :parent top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'OccurrenceC :item-identifiers (list ii-1))) (signals error (make-construct 'OccurrenceC :reifier reifier-1)) @@ -2141,6 +2189,7 @@ :charvalue "charvalue-2" :parent top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'NameC :item-identifiers (list ii-1))) (signals error (make-construct 'NameC :reifier reifier-1)) @@ -2195,6 +2244,7 @@ :charvalue "charvalue-2" :parent name-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'VariantC :item-identifiers (list ii-1))) (signals error (make-construct 'VariantC :reifier reifier-1)) @@ -2243,6 +2293,7 @@ (role-3 (make-construct 'RoleC :parent assoc-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'RoleC :item-identifiers (list ii-1))) (signals error (make-construct 'RoleC :reifier reifier-1)) @@ -2266,7 +2317,6 @@ (is (eql role-3 (find-item-by-revision role-3 rev-1 assoc-1)))))))
- (test test-make-TopicMapC () "Tests the function make-construct corresponding to TopicMapC." (with-fixture with-empty-db (*db-dir*) @@ -2291,6 +2341,7 @@ (tm-2 (make-construct 'TopicMapC :start-revision rev-1 :item-identifiers (list ii-3)))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'TopicMapC)) (is (eql (reifier tm-1) reifier-1)) (is (= (length (item-identifiers tm-1)) 2)) @@ -2323,6 +2374,117 @@ (is (eql (find-item-by-revision tm-3 rev-1) tm-3)))))))
+(test test-make-AssociationC () + "Tests the function make-construct corresponding to TopicMapC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (player-1 (make-instance 'TopicC)) + (player-2 (make-instance 'TopicC)) + (type-1 (make-instance 'TopicC)) + (r-type-1 (make-instance 'TopicC)) + (r-type-2 (make-instance 'TopicC)) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (reifier-1 (make-instance 'TopicC)) + (r-reifier-1 (make-instance 'TopicC)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (r-ii-1 (make-construct 'ItemIdentifierC :uri "r-ii-1")) + (r-ii-2 (make-construct 'ItemIdentifierC :uri "r-ii-2")) + (r-ii-3 (make-construct 'ItemIdentifierC :uri "r-ii-3"))) + (let ((role-1 (list :item-identifiers (list r-ii-1) :player player-1 + :instance-of r-type-1 :reifier r-reifier-1 + :start-revision rev-1)) + (role-2 (list :item-identifiers (list r-ii-2 r-ii-3) + :player player-2 :instance-of r-type-2 + :start-revision rev-1)) + (role-2-2 (list :player player-2 :instance-of r-type-2 + :start-revision rev-1)) + (tm-1 (make-construct 'TopicMapC :start-revision rev-1)) + (tm-2 (make-construct 'TopicMapC :start-revision rev-1))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :themes (list theme-1 theme-2) + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :in-topicmaps (list tm-1 tm-2) + :roles (list role-1 role-2 role-2-2))) + (assoc-2 (make-construct 'AssociationC :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (signals error (make-construct 'AssociationC)) + (signals error (make-construct 'AssociationC + :start-revision rev-1 + :roles (list + (list :player player-1 + :instance-of r-type-1)))) + (is (eql (instance-of assoc-1) type-1)) + (is-true (themes assoc-1)) + (is (= (length (union (list theme-1 theme-2) (themes assoc-1))) 2)) + (is-true (item-identifiers assoc-1)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers assoc-1))) 2)) + (is (eql (reifier assoc-1) reifier-1)) + (is-true (in-topicmaps assoc-1)) + (is (= (length (union (list tm-1 tm-2) (in-topicmaps assoc-1))) 2)) + (is (= (length (roles assoc-1)) 2)) + (is (= (length + (remove-if + #'null + (map + 'list + #'(lambda(role) + (when (or (and (eql (player role :revision rev-1) + player-1) + (eql (instance-of role :revision rev-1) + r-type-1) + (= (length (item-identifiers + role :revision rev-1)) 1) + (string= + (uri (first (item-identifiers role))) + "r-ii-1")) + (and (eql (player role :revision rev-1) + player-2) + (eql (instance-of role :revision rev-1) + r-type-2) + (= (length (item-identifiers role)) 2) + (let ((uri-1 + (uri (first + (item-identifiers + role :revision rev-1)))) + (uri-2 + (uri (second + (item-identifiers + role :revision rev-1))))) + (and (or (string= uri-1 "r-ii-2") + (string= uri-2 "r-ii-2")) + (or (string= uri-1 "r-ii-3") + (string= uri-2 "r-ii-3")))))) + role)) + (roles assoc-1 :revision rev-1)))) + 2)) + (is (eql (find-item-by-revision assoc-1 rev-1) assoc-1)) + (is-false (item-identifiers assoc-2)) + (is-false (reifier assoc-2)) + (is-false (instance-of assoc-2)) + (is-false (themes assoc-2)) + (is-false (roles assoc-2)) + (is-false (in-topicmaps assoc-2)) + (let ((assoc-3 (make-construct 'AssociationC + :start-revision rev-1 + :roles (list role-1 role-2) + :instance-of type-1 + :themes (list theme-1 theme-2)))) + (is (eql (instance-of assoc-3) type-1)) + (is-true (themes assoc-3)) + (is (= (length (union (list theme-1 theme-2) (themes assoc-3))) 2)) + (is-true (item-identifiers assoc-3)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers assoc-3))) 2)) + (is (eql (reifier assoc-3) reifier-1)) + (is-true (in-topicmaps assoc-3)) + (is (= (length (union (list tm-1 tm-2) (in-topicmaps assoc-3))) 2)) + (is (= (length (roles assoc-3)) 2)))))))) + +
(defun run-datamodel-tests() @@ -2378,4 +2540,5 @@ (it.bese.fiveam:run! 'test-make-VariantC) (it.bese.fiveam:run! 'test-make-RoleC) (it.bese.fiveam:run! 'test-make-TopicMapC) + (it.bese.fiveam:run! 'test-make-AssociationC) ) \ No newline at end of file