[isidorus-cvs] r252 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Mar 24 16:37:21 UTC 2010
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
More information about the Isidorus-cvs
mailing list