March 2010 - isidorus-cvs@common-lisp.net

[isidorus-cvs] r254 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 27 Mar '10

27 Mar '10

Author: lgiessmann Date: Sat Mar 27 16:30:12 2010 New Revision: 254 Log: new-datamodel: added the generic "equivalent-constructs" that checks the TMDM equality of two "TopicMapConstructC"s and is needed for "merge-constructs" 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 Sat Mar 27 16:30:12 2010 @@ -155,7 +155,6 @@ (in-package :datamodel) - ;;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), @@ -779,7 +778,14 @@ (defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) (:documentation "Returns t if the passed construct is equivalent to the passed - key arguments (TMDM equality rules. Parent-equality is not + key arguments (TMDM equality rules). Parent-equality is not + checked in this methods, so the user has to pass children of + the same parent.")) + + +(defgeneric equivalent-constructs (construct-1 construct-2 &key revision) + (:documentation "Returns t if the passed constructs are equivalent to each + other (TMDM equality rules). Parent-equality is not checked in this methods, so the user has to pass children of the same parent.")) @@ -923,6 +929,17 @@ ;;; TopicMapconstructC +(defgeneric strictly-equivalent-constructs (construct-1 construct-2 + &key revision) + (:documentation "Checks if two topic map constructs are not identical but + equal according to the TMDM equality rules.") + (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (equivalent-constructs construct-1 construct-2 :revision revision) + (not (eql construct-1 construct-2))))) + + (defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC) &key revision) (declare (ignorable revision construct)) @@ -948,6 +965,12 @@ ;;; PointerC +(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC) + &key (revision nil)) + (declare (ignorable revision)) + (string= (uri construct-1) (uri construct-2))) + + (defgeneric PointerC-p (class-symbol) (:documentation "Returns t if the passed symbol corresponds to the class PointerC or one of its subclasses.") @@ -1018,6 +1041,14 @@ ;;; TopicIdentificationC +(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC) + &key (revision nil)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (xtm-id construct-1) (xtm-id construct-2)))) + + + (defgeneric TopicIdentificationC-p (class-symbol) (:documentation "Returns t if the passed class symbol is equal to TopicIdentificationC.") @@ -1143,6 +1174,20 @@ ;;; TopicC +(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (when (intersection (union + (union (item-identifiers construct-1 :revision revision) + (locators construct-1 :revision revision)) + (psis construct-1 :revision revision)) + (union + (union (item-identifiers construct-2 :revision revision) + (locators construct-2 :revision revision)) + (psis construct-2 :revision revision))) + t)) + + (defgeneric TopicC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to TopicC.") (:method ((class-symbol symbol)) @@ -1714,6 +1759,17 @@ ;;; CharacteristicC +(defmethod equivalent-constructs ((construct-1 CharacteristicC) + (construct-2 CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (string= (charvalue construct-1) (charvalue construct-2)) + (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)) + (not (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision))))) + + (defgeneric CharacteristicC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to CharacteristicC or one of its subtypes.") @@ -1845,6 +1901,13 @@ ;;; OccurrenceC +(defmethod equivalent-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (datatype construct-1) (datatype construct-2)))) + + (defgeneric OccurrenceC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to OccurrenceC.") (:method ((class-symbol symbol)) @@ -1867,6 +1930,13 @@ ;;; VariantC +(defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (datatype construct-1) (datatype construct-2)))) + + (defgeneric VariantC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to VariantC.") (:method ((class-symbol symbol)) @@ -1977,6 +2047,18 @@ ;;; AssociationC +(defmethod equivalent-constructs ((construct-1 AssociationC) + (construct-2 AssociationC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (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))))) + + (defgeneric AssociationC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to AssociationC.") (:method ((class-symbol symbol)) @@ -2082,6 +2164,15 @@ ;;; RoleC +(defmethod equivalent-constructs ((construct-1 RoleC) (construct-2 RoleC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)) + (eql (player construct-1 :revision revision) + (player construct-1 :revision revision)))) + + (defgeneric RoleC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to RoleC.") (:method ((class-symbol symbol)) @@ -2364,6 +2455,11 @@ (let ((id-owner (identified-construct item-identifier :revision revision))) (when (not (eql id-owner construct)) + (unless (typep construct 'TopicC) + (error (make-condition 'duplicate-identifier-error + :message "From add-item-identifier(): duplicate ItemIdentifier has been found: ~a" + (uri item-identifier) + :uri (uri item-identifier)))) id-owner)))) (let ((merged-construct construct)) (cond (construct-to-be-merged @@ -2649,6 +2745,14 @@ ;;; TopicMapC +(defmethod equivalent-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (when (intersection (item-identifiers construct-1 :revision revision) + (item-identifiers construct-2 :revision revision)) + t)) + + (defgeneric TopicMapC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to TopicMapC.") (:method ((class-symbol symbol)) 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 Sat Mar 27 16:30:12 2010 @@ -75,6 +75,7 @@ :test-make-TopicC)) +;;TODO: test equivalent-constructs ;;TODO: test merge-constructs

1 0

[isidorus-cvs] r253 - branches/new-datamodel/src/unit_tests
by Lukas Giessmann 24 Mar '10

24 Mar '10

Author: lgiessmann Date: Wed Mar 24 14:06:03 2010 New Revision: 253 Log: new-datamodel: added unit-tests for "make-construct" --> "TopicC" Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp 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 14:06:03 2010 @@ -71,10 +71,10 @@ :test-make-VariantC :test-make-RoleC :test-make-TopicMapC - :test-make-AssociationC)) + :test-make-AssociationC + :test-make-TopicC)) -;;TODO: test make-construct ;;TODO: test merge-constructs @@ -2485,6 +2485,86 @@ (is (= (length (roles assoc-3)) 2)))))))) +(test test-make-TopicC () + "Tests the function make-construct corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (psi-3 (make-construct 'PersistentIdC :uri "psi-3")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) + (sl-3 (make-construct 'SubjectLocatorC :uri "sl-3")) + (variant-1 (make-construct 'VariantC :datatype "dt-1" + :charvalue "cv-1")) + (variant-2 (make-construct 'VariantC :datatype "dt-2" + :charvalue "cv-2")) + (type-1 (make-instance 'TopicC)) + (type-2 (make-instance 'TopicC)) + (type-3 (make-instance 'TopicC)) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (theme-3 (make-instance 'TopicC))) + (let ((name-1 (make-construct 'NameC :charvalue "cv-3" + :start-revision rev-1 + :variants (list variant-1) + :instance-of type-1 + :themes (list theme-1 theme-2))) + (name-2 (make-construct 'NameC :charvalue "cv-4" + :start-revision rev-1 + :variants (list variant-2) + :instance-of type-2 + :themes (list theme-3 theme-2))) + (occ-1 (make-construct 'OccurrenceC :charvalue "cv-5" + :start-revision rev-1 + :themes (list theme-1) + :instance-of type-3))) + (let ((top-1 (make-construct 'TopicC :start-revision rev-1)) + (top-2 (make-construct 'TopicC :start-revision rev-1 + :item-identifiers (list ii-1 ii-2) + :psis (list psi-1 psi-2 psi-3) + :locators (list sl-1 sl-2) + :names (list name-1) + :occurrences (list occ-1)))) + (setf *TM-REVISION* rev-1) + (signals error (make-construct 'TopicC)) + (is-false (item-identifiers top-1)) + (is-false (psis top-1)) + (is-false (locators top-1)) + (is-false (names top-1)) + (is-false (occurrences top-1)) + (is (eql (find-item-by-revision top-1 rev-1) top-1)) + (is (= (length (item-identifiers top-2)) 2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers top-2))) 2)) + (is (= (length (locators top-2)) 2)) + (is (= (length (union (list sl-1 sl-2) (locators top-2))) 2)) + (is (= (length (psis top-2)) 3)) + (is (= (length (union (list psi-1 psi-2 psi-3) (psis top-2))) 3)) + (is (= (length (names top-2)) 1)) + (is (eql (first (names top-2)) name-1)) + (is (= (length (occurrences top-2)) 1)) + (is (eql (first (occurrences top-2)) occ-1)) + (is (eql (find-item-by-revision occ-1 rev-1 top-2) occ-1)) + (let ((top-3 (make-construct 'TopicC :start-revision rev-1 + :item-identifiers (list ii-2 ii-3) + :locators (list sl-3) + :names (list name-2)))) + (is (= (length (item-identifiers top-3)) 3)) + (is (= (length (union (list ii-1 ii-2 ii-3) + (item-identifiers top-3))) 3)) + (is (= (length (locators top-3)) 3)) + (is (= (length (union (list sl-1 sl-2 sl-3) (locators top-3))) 3)) + (is (= (length (psis top-3)) 3)) + (is (= (length (union (list psi-1 psi-2 psi-3) (psis top-3))) 3)) + (is (= (length (names top-3)) 2)) + (is (= (length (union (list name-1 name-2) (names top-3))) 2)) + (is (= (length (occurrences top-3)) 1)) + (is (eql (first (occurrences top-3)) occ-1)))))))) + + (defun run-datamodel-tests() @@ -2541,4 +2621,5 @@ (it.bese.fiveam:run! 'test-make-RoleC) (it.bese.fiveam:run! 'test-make-TopicMapC) (it.bese.fiveam:run! 'test-make-AssociationC) + (it.bese.fiveam:run! 'test-make-TopicC) ) \ No newline at end of file

1 0

[isidorus-cvs] r252 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 24 Mar '10

24 Mar '10

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

1 0

[isidorus-cvs] r251 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 24 Mar '10

24 Mar '10

Author: lgiessmann Date: Wed Mar 24 05:47:39 2010 New Revision: 251 Log: new-datamodel: added unit-tests for "make-construct" --> "TopicMapC"; fixed a parameter bug in "make-tm" and "make-association" 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 05:47:39 2010 @@ -2736,7 +2736,7 @@ construct))) -(defun make-association (args) +(defun make-association (&rest args) "Returns an association object. If the association has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" @@ -2800,7 +2800,7 @@ role))) -(defun make-tm (args) +(defun make-tm (&rest args) "Returns a topic map object. If the topic map has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" 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 05:47:39 2010 @@ -69,7 +69,8 @@ :test-make-OccurrenceC :test-make-NameC :test-make-VariantC - :test-make-RoleC)) + :test-make-RoleC + :test-make-TopicMapC)) ;;TODO: test make-construct @@ -2266,6 +2267,64 @@ +(test test-make-TopicMapC () + "Tests the function make-construct corresponding to TopicMapC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (top-3 (make-instance 'TopicC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (assoc-3 (make-instance 'AssociationC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-instance 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-instance 'ItemIdentifierC :uri "ii-4")) + (reifier-1 (make-instance 'TopicC))) + (let ((tm-1 (make-construct 'TopicMapC + :start-revision rev-1 + :topics (list top-1 top-2) + :associations (list assoc-1 assoc-2) + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1)) + (tm-2 (make-construct 'TopicMapC + :start-revision rev-1 + :item-identifiers (list ii-3)))) + (signals error (make-construct 'TopicMapC)) + (is (eql (reifier tm-1) reifier-1)) + (is (= (length (item-identifiers tm-1)) 2)) + (is (= (length (union (item-identifiers tm-1) (list ii-1 ii-2))) 2)) + (is (= (length (topics tm-1)) 2)) + (is (= (length (union (topics tm-1) (list top-1 top-2))) 2)) + (is (= (length (associations tm-1)) 2)) + (is (= (length (union (associations tm-1) (list assoc-1 assoc-2))) 2)) + (is (eql (find-item-by-revision tm-1 rev-1) tm-1)) + (is (= (length (item-identifiers tm-2)) 1)) + (is (= (length (union (item-identifiers tm-2) (list ii-3))) 1)) + (is-false (topics tm-2)) + (is-false (associations tm-2)) + (is-false (reifier tm-2)) + (let ((tm-3 (make-construct 'TopicMapC + :start-revision rev-1 + :topics (list top-3) + :associations (list assoc-3) + :item-identifiers (list ii-2 ii-4)))) + (is (eql (reifier tm-3) reifier-1)) + (is (= (length (item-identifiers tm-3)) 3)) + (is (= (length (union (item-identifiers tm-3) (list ii-1 ii-2 ii-4))) + 3)) + (is (= (length (topics tm-3)) 3)) + (is (= (length (union (topics tm-3) (list top-1 top-2 top-3))) 3)) + (is (= (length (associations tm-3)) 3)) + (is (= (length (union (associations tm-3) + (list assoc-1 assoc-2 assoc-3))) + 3)) + (is (eql (find-item-by-revision tm-3 rev-1) tm-3))))))) + + + + (defun run-datamodel-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) @@ -2318,4 +2377,5 @@ (it.bese.fiveam:run! 'test-make-NameC) (it.bese.fiveam:run! 'test-make-VariantC) (it.bese.fiveam:run! 'test-make-RoleC) + (it.bese.fiveam:run! 'test-make-TopicMapC) ) \ No newline at end of file

1 0

[isidorus-cvs] r250 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 24 Mar '10

24 Mar '10

Author: lgiessmann Date: Wed Mar 24 05:18:11 2010 New Revision: 250 Log: new-datamodel: added unit-tests for "make-conmstruct" --> "RoleC"; fixed 2 bugs in "make-role" 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 05:18:11 2010 @@ -2767,7 +2767,7 @@ association))) -(defun make-role (args) +(defun make-role (&rest args) "Returns a role object. If the role has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" @@ -2780,15 +2780,16 @@ (error "From make-role(): start-revision must be set")) (let ((role (let ((existing-role - (remove-if - #'null - (map 'list #'(lambda(existing-role) - (when (equivalent-construct - existing-role - :player player - :instance-of instance-of) - existing-role)) - (slot-p parent 'roles))))) + (when parent + (remove-if + #'null + (map 'list #'(lambda(existing-role) + (when (equivalent-construct + existing-role + :player player + :instance-of instance-of) + existing-role)) + (slot-p parent 'roles)))))) (if existing-role existing-role (make-instance 'RoleC))))) 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 05:18:11 2010 @@ -68,7 +68,8 @@ :test-make-ItemIdentifierC :test-make-OccurrenceC :test-make-NameC - :test-make-VariantC)) + :test-make-VariantC + :test-make-RoleC)) ;;TODO: test make-construct @@ -2219,6 +2220,50 @@ (is (eql variant-3 (find-item-by-revision variant-3 rev-1 name-1))))))) +(test test-make-RoleC () + "Tests the function make-construct corresponding to RoleC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0-5 50) + (rev-1 100) + (type-1 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (player-1 (make-instance 'TopicC)) + (reifier-1 (make-instance 'TopicC)) + (assoc-1 (make-instance 'AssociationC))) + (setf *TM-REVISION* rev-1) + (let ((role-1 (make-construct 'RoleC)) + (role-2 (make-construct 'RoleC + :item-identifiers (list ii-1 ii-2) + :player player-1 + :reifier reifier-1 + :instance-of type-1 + :start-revision rev-1)) + (role-3 (make-construct 'RoleC + :parent assoc-1 + :start-revision rev-1))) + (signals error (make-construct 'RoleC + :item-identifiers (list ii-1))) + (signals error (make-construct 'RoleC :reifier reifier-1)) + (signals error (make-construct 'RoleC :parent assoc-1)) + (signals error (make-construct 'RoleC :instance-of type-1)) + (signals error (make-construct 'RoleC :player player-1)) + (is-false (item-identifiers role-1)) + (is-false (reifier role-1)) + (is-false (instance-of role-1)) + (is-false (parent role-1)) + (is-false (player role-1)) + (is-true (item-identifiers role-2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers role-2))) 2)) + (is (eql (reifier role-2) reifier-1)) + (is (eql (instance-of role-2) type-1)) + (is-false (parent role-2)) + (is (eql (player role-2) player-1)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-1 role-2))) + (is-false (item-identifiers role-2 :revision rev-0-5)) + (is (eql (parent role-3) assoc-1)) + (is (eql role-3 (find-item-by-revision role-3 rev-1 assoc-1))))))) + (defun run-datamodel-tests() @@ -2272,4 +2317,5 @@ (it.bese.fiveam:run! 'test-make-OccurrenceC) (it.bese.fiveam:run! 'test-make-NameC) (it.bese.fiveam:run! 'test-make-VariantC) + (it.bese.fiveam:run! 'test-make-RoleC) ) \ No newline at end of file

1 0

[isidorus-cvs] r249 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 23 Mar '10

23 Mar '10

Author: lgiessmann Date: Tue Mar 23 14:45:50 2010 New Revision: 249 Log: new-datamodel: added unit-tests for "make-construct" corresponding to "OccurrenceC", "NameC" and "VariantC" 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 Tue Mar 23 14:45:50 2010 @@ -981,16 +981,17 @@ (slot-p construct 'identified-construct))))) (when assocs (first assocs))))) - (cond ((= revision 0) - (find-most-recent-revision parent-assoc)) - (t - (when (find-if - #'(lambda(vi) - (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) - (versions parent-assoc)) - construct)))) + (when parent-assoc + (cond ((= revision 0) + (find-most-recent-revision parent-assoc)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) nil)) @@ -1754,18 +1755,19 @@ (slot-p construct 'parent))))) (when assocs (first assocs))))) - (cond ((= revision 0) - (when - (find-most-recent-revision parent-assoc) - construct)) - (t - (when (find-if - #'(lambda(vi) - (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) - (versions parent-assoc)) - construct)))) + (when parent-assoc + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) nil)) @@ -2084,29 +2086,32 @@ (defmethod find-item-by-revision ((construct RoleC) (revision integer) &optional parent-construct) - (let ((parent-assoc - (let ((assocs - (remove-if - #'null - (map 'list #'(lambda(assoc) - (when (eql (parent-construct assoc) - parent-construct) - assoc)) - (slot-p construct 'parent))))) - (when assocs - (first assocs))))) - (cond ((= revision 0) - (when - (find-most-recent-revision parent-assoc) - construct)) - (t - (when (find-if - #'(lambda(vi) - (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) - (versions parent-assoc)) - construct))))) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'parent))))) + (when assocs + (first assocs))))) + (when parent-assoc + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) + nil)) (defmethod delete-construct :before ((construct RoleC)) @@ -2692,7 +2697,9 @@ history accordingly. Returns the object in question. Methods use specific keyword arguments for their purpose." (declare (symbol class-symbol)) - (when (and (VersionedConstructC-p class-symbol) + (when (and (or (VersionedConstructC-p class-symbol) + (and (ReifiableConstructC-p class-symbol) + (or (getf args :item-identifiers) (getf args :reifier)))) (not (getf args :start-revision))) (error "From make-construct(): start-revision must be set")) (let ((construct @@ -2714,7 +2721,7 @@ (rec-remf args :start-revision))) (t (apply #'make-instance class-symbol args)))) - (start-revision (getf args :start-revision))) + (start-revision (or (getf args :start-revision) *TM-REVISION*))) (when (typep construct 'TypableC) (complete-typable construct (getf args :instance-of) :start-revision start-revision)) @@ -2724,7 +2731,7 @@ (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision start-revision)) (if (typep construct 'ReifiableConstructC) - (complete-reifiable construct (getf args :item-identtifiers) + (complete-reifiable construct (getf args :item-identifiers) (getf args :reifier) :start-revision start-revision) construct))) @@ -2881,9 +2888,9 @@ To check if there is existing an equivalent construct the parameter parent-construct must be set. This function only exists for being used by make-construct!" - (let ((charvalue (getf args :charvalue)) + (let ((charvalue (or (getf args :charvalue) "")) (start-revision (getf args :start-revision)) - (datatype (getf args :datatype)) + (datatype (or (getf args :datatype) *xml-string*)) (instance-of (getf args :instance-of)) (themes (getf args :themes)) (variants (getf args :variants)) @@ -2909,7 +2916,8 @@ existing-characteristic (make-instance class-symbol :charvalue charvalue :datatype datatype))))) - (complete-name characteristic variants :start-revision start-revision) + (when (typep characteristic 'NameC) + (complete-name characteristic variants :start-revision start-revision)) (when parent (add-parent characteristic parent :revision start-revision)) characteristic))) @@ -2922,9 +2930,15 @@ (let ((uri (getf args :uri)) (xtm-id (getf args :xtm-id)) (start-revision (getf args :start-revision)) - (identified-construct (getf args :identified-construct))) + (identified-construct (getf args :identified-construct)) + (err "From make-pointer(): ")) (when (and identified-construct (not start-revision)) - (error "From make-pointer(): start-revision must be set")) + (error "~astart-revision must be set" err)) + (unless uri + (error "~auri must be set" err)) + (when (and (TopicIdentificationC-p class-symbol) + (not xtm-id)) + (error "~axtm-id must be set" err)) (let ((identifier (let ((existing-pointer (remove-if 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 Tue Mar 23 14:45:50 2010 @@ -65,7 +65,10 @@ :test-make-TopicIdentificationC :test-make-PersistentIdC :test-make-SubjectLocatorC - :test-make-ItemIdentifierC)) + :test-make-ItemIdentifierC + :test-make-OccurrenceC + :test-make-NameC + :test-make-VariantC)) ;;TODO: test make-construct @@ -1887,7 +1890,7 @@ :accessor value))) (let ((construct (make-construct 'Unknown :value "value"))) (is-true construct) - (string= (value construct) "value"))) + (is (string= (value construct) "value")))) (test test-make-VersionedConstructC () @@ -1933,6 +1936,10 @@ :uri "tid-2" :xtm-id "xtm-id-2" :identified-construct top-1 :start-revision rev-1))) + (signals error (make-construct 'TopicIdentificationC + :uri "uri")) + (signals error (make-construct 'TopicIdentificationC + :xtm-id "xtm-id")) (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)) @@ -1966,6 +1973,7 @@ :uri "psi-2" :identified-construct top-1 :start-revision rev-1))) + (signals error (make-construct 'PersistentIdC)) (is (string= (uri psi-1) "psi-1")) (is-false (d::slot-p psi-1 'd::identified-construct)) (is (string= (uri psi-2) "psi-2")) @@ -1997,6 +2005,7 @@ :uri "sl-2" :identified-construct top-1 :start-revision rev-1))) + (signals error (make-construct 'SubjectLocatorC)) (is (string= (uri sl-1) "sl-1")) (is-false (d::slot-p sl-1 'd::identified-construct)) (is (string= (uri sl-2) "sl-2")) @@ -2028,6 +2037,7 @@ :uri "ii-2" :identified-construct top-1 :start-revision rev-1))) + (signals error (make-construct 'ItemIdentifierC)) (is (string= (uri ii-1) "ii-1")) (is-false (d::slot-p ii-1 'd::identified-construct)) (is (string= (uri ii-2) "ii-2")) @@ -2045,7 +2055,168 @@ (is (eql (identified-construct ii-2 :revision rev-1) top-1)) (is-false (identified-construct ii-2 :revision rev-0-5)) (is (eql (find-item-by-revision ii-2 rev-1 top-1) ii-2)))))) - + + +(test test-make-OccurrenceC () + "Tests the function make-construct corresponding to OccurrenceC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0-5 50) + (rev-1 100) + (type-1 (make-instance 'TopicC)) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'TopicC)) + (top-1 (make-instance 'TopicC))) + (setf *TM-REVISION* rev-1) + (let ((occ-1 (make-construct 'OccurrenceC)) + (occ-2 (make-construct 'OccurrenceC + :charvalue "charvalue" + :datatype "datatype" + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :instance-of type-1 + :themes (list theme-1 theme-2) + :start-revision rev-1)) + (occ-3 (make-construct 'OccurrenceC + :charvalue "charvalue-2" + :parent top-1 + :start-revision rev-1))) + (signals error (make-construct 'OccurrenceC + :item-identifiers (list ii-1))) + (signals error (make-construct 'OccurrenceC :reifier reifier-1)) + (signals error (make-construct 'OccurrenceC :parent top-1)) + (signals error (make-construct 'OccurrenceC :instance-of type-1)) + (signals error (make-construct 'OccurrenceC :themes (list theme-1))) + (is (string= (charvalue occ-1) "")) + (is (string= (datatype occ-1) *xml-string*)) + (is-false (item-identifiers occ-1)) + (is-false (reifier occ-1)) + (is-false (instance-of occ-1)) + (is-false (themes occ-1)) + (is-false (parent occ-1)) + (is (string= (charvalue occ-2) "charvalue")) + (is (string= (datatype occ-2) "datatype")) + (is-true (item-identifiers occ-2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers occ-2))) 2)) + (is (eql (reifier occ-2) reifier-1)) + (is (eql (instance-of occ-2) type-1)) + (is-true (themes occ-2)) + (is (= (length (union (list theme-1 theme-2) (themes occ-2))) 2)) + (is-false (parent occ-2)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-1 occ-2))) + (is-false (item-identifiers occ-2 :revision rev-0-5)) + (is (eql (parent occ-3) top-1)) + (is (eql occ-3 (find-item-by-revision occ-3 rev-1 top-1))))))) + + +(test test-make-NameC () + "Tests the function make-construct corresponding to NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0-5 50) + (rev-1 100) + (type-1 (make-instance 'TopicC)) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'TopicC)) + (variant-1 (make-instance 'VariantC)) + (variant-2 (make-instance 'VariantC)) + (top-1 (make-instance 'TopicC))) + (setf *TM-REVISION* rev-1) + (let ((name-1 (make-construct 'NameC)) + (name-2 (make-construct 'NameC + :charvalue "charvalue" + :variants (list variant-1 variant-2) + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :instance-of type-1 + :themes (list theme-1 theme-2) + :start-revision rev-1)) + (name-3 (make-construct 'NameC + :charvalue "charvalue-2" + :parent top-1 + :start-revision rev-1))) + (signals error (make-construct 'NameC + :item-identifiers (list ii-1))) + (signals error (make-construct 'NameC :reifier reifier-1)) + (signals error (make-construct 'NameC :parent top-1)) + (signals error (make-construct 'NameC :instance-of type-1)) + (signals error (make-construct 'NameC :themes (list theme-1))) + (signals error (make-construct 'NameC :variants (list variant-1))) + (is (string= (charvalue name-1) "")) + (is-false (item-identifiers name-1)) + (is-false (reifier name-1)) + (is-false (instance-of name-1)) + (is-false (themes name-1)) + (is-false (parent name-1)) + (is-false (variants name-1)) + (is (string= (charvalue name-2) "charvalue")) + (is-true (item-identifiers name-2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers name-2))) 2)) + (is (eql (reifier name-2) reifier-1)) + (is (eql (instance-of name-2) type-1)) + (is-true (themes name-2)) + (is (= (length (union (list theme-1 theme-2) (themes name-2))) 2)) + (is-true (variants name-2)) + (is (= (length (union (list variant-1 variant-2) (variants name-2))) 2)) + (is-false (parent name-2)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-1 name-2))) + (is-false (item-identifiers name-2 :revision rev-0-5)) + (is (eql (parent name-3) top-1)) + (is (eql name-3 (find-item-by-revision name-3 rev-1 top-1))))))) + + +(test test-make-VariantC () + "Tests the function make-construct corresponding to VariantC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0-5 50) + (rev-1 100) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'TopicC)) + (name-1 (make-instance 'NameC))) + (setf *TM-REVISION* rev-1) + (let ((variant-1 (make-construct 'VariantC)) + (variant-2 (make-construct 'VariantC + :charvalue "charvalue" + :datatype "datatype" + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :themes (list theme-1 theme-2) + :start-revision rev-1)) + (variant-3 (make-construct 'VariantC + :charvalue "charvalue-2" + :parent name-1 + :start-revision rev-1))) + (signals error (make-construct 'VariantC + :item-identifiers (list ii-1))) + (signals error (make-construct 'VariantC :reifier reifier-1)) + (signals error (make-construct 'VariantC :parent name-1)) + (signals error (make-construct 'VariantC :themes (list theme-1))) + (is (string= (charvalue variant-1) "")) + (is (string= (datatype variant-1) *xml-string*)) + (is-false (item-identifiers variant-1)) + (is-false (reifier variant-1)) + (is-false (instance-of variant-1)) + (is-false (themes variant-1)) + (is-false (parent variant-1)) + (is (string= (charvalue variant-2) "charvalue")) + (is (string= (datatype variant-2) "datatype")) + (is-true (item-identifiers variant-2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers variant-2))) 2)) + (is (eql (reifier variant-2) reifier-1)) + (is-true (themes variant-2)) + (is (= (length (union (list theme-1 theme-2) (themes variant-2))) 2)) + (is-false (parent variant-2)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-1 variant-2))) + (is-false (item-identifiers variant-2 :revision rev-0-5)) + (is (eql (parent variant-3) name-1)) + (is (eql variant-3 (find-item-by-revision variant-3 rev-1 name-1))))))) @@ -2098,4 +2269,7 @@ (it.bese.fiveam:run! 'test-make-PersistentIdC) (it.bese.fiveam:run! 'test-make-SubjectLocatorC) (it.bese.fiveam:run! 'test-make-ItemIdentifierC) + (it.bese.fiveam:run! 'test-make-OccurrenceC) + (it.bese.fiveam:run! 'test-make-NameC) + (it.bese.fiveam:run! 'test-make-VariantC) ) \ No newline at end of file

1 0

[isidorus-cvs] r248 - branches/new-datamodel/src/unit_tests
by Lukas Giessmann 22 Mar '10

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 17:58:31 2010 New Revision: 248 Log: new-datamodel: added unit-tests for "make-construct" related to "ItemIdentifierC", "PersistentIdC", "SubjectLocatorC" and "TopicIdentificationC" Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp 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 Mon Mar 22 17:58:31 2010 @@ -61,7 +61,11 @@ :test-class-p :test-find-item-by-revision :test-make-Unknown - :test-make-VersionedConstructC)) + :test-make-VersionedConstructC + :test-make-TopicIdentificationC + :test-make-PersistentIdC + :test-make-SubjectLocatorC + :test-make-ItemIdentifierC)) ;;TODO: test make-construct @@ -1916,6 +1920,134 @@ (d::versions psi-assoc))))))) +(test test-make-TopicIdentificationC () + "Tests the function make-construct corresponding to TopicIdentificationC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0 0) + (rev-0-5 50) + (rev-1 100) + (top-1 (make-instance 'TopicC))) + (let ((tid-1 (make-construct 'TopicIdentificationC + :uri "tid-1" :xtm-id "xtm-id-1")) + (tid-2 (make-construct 'TopicIdentificationC + :uri "tid-2" :xtm-id "xtm-id-2" + :identified-construct top-1 + :start-revision rev-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)) + (is (string= (uri tid-2) "tid-2")) + (is (string= (xtm-id tid-2) "xtm-id-2")) + (is (= (length (d::slot-p tid-2 'd::identified-construct)) 1)) + (is (= (length (d::versions + (first (d::slot-p tid-2 'd::identified-construct)))) 1)) + (is (= (d::start-revision + (first (d::versions + (first (d::slot-p tid-2 'd::identified-construct))))) + rev-1)) + (is (= (d::end-revision + (first (d::versions + (first (d::slot-p tid-2 'd::identified-construct))))) + rev-0)) + (is (eql (identified-construct tid-2 :revision rev-1) top-1)) + (is-false (identified-construct tid-2 :revision rev-0-5)) + (is (eql (find-item-by-revision tid-2 rev-1 top-1) tid-2)))))) + + +(test test-make-PersistentIdC () + "Tests the function make-construct corresponding to PersistentIdC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0 0) + (rev-0-5 50) + (rev-1 100) + (top-1 (make-instance 'TopicC))) + (let ((psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC + :uri "psi-2" + :identified-construct top-1 + :start-revision rev-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")) + (is (= (length (d::slot-p psi-2 'd::identified-construct)) 1)) + (is (= (length (d::versions + (first (d::slot-p psi-2 'd::identified-construct)))) 1)) + (is (= (d::start-revision + (first (d::versions + (first (d::slot-p psi-2 'd::identified-construct))))) + rev-1)) + (is (= (d::end-revision + (first (d::versions + (first (d::slot-p psi-2 'd::identified-construct))))) + rev-0)) + (is (eql (identified-construct psi-2 :revision rev-1) top-1)) + (is-false (identified-construct psi-2 :revision rev-0-5)) + (is (eql (find-item-by-revision psi-2 rev-1 top-1) psi-2)))))) + + +(test test-make-SubjectLocatorC () + "Tests the function make-construct corresponding to SubjectLocatorC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0 0) + (rev-0-5 50) + (rev-1 100) + (top-1 (make-instance 'TopicC))) + (let ((sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-construct 'SubjectLocatorC + :uri "sl-2" + :identified-construct top-1 + :start-revision rev-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")) + (is (= (length (d::slot-p sl-2 'd::identified-construct)) 1)) + (is (= (length (d::versions + (first (d::slot-p sl-2 'd::identified-construct)))) 1)) + (is (= (d::start-revision + (first (d::versions + (first (d::slot-p sl-2 'd::identified-construct))))) + rev-1)) + (is (= (d::end-revision + (first (d::versions + (first (d::slot-p sl-2 'd::identified-construct))))) + rev-0)) + (is (eql (identified-construct sl-2 :revision rev-1) top-1)) + (is-false (identified-construct sl-2 :revision rev-0-5)) + (is (eql (find-item-by-revision sl-2 rev-1 top-1) sl-2)))))) + + +(test test-make-ItemIdentifierC () + "Tests the function make-construct corresponding to ItemIdentifierC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0 0) + (rev-0-5 50) + (rev-1 100) + (top-1 (make-instance 'AssociationC))) + (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC + :uri "ii-2" + :identified-construct top-1 + :start-revision rev-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")) + (is (= (length (d::slot-p ii-2 'd::identified-construct)) 1)) + (is (= (length (d::versions + (first (d::slot-p ii-2 'd::identified-construct)))) 1)) + (is (= (d::start-revision + (first (d::versions + (first (d::slot-p ii-2 'd::identified-construct))))) + rev-1)) + (is (= (d::end-revision + (first (d::versions + (first (d::slot-p ii-2 'd::identified-construct))))) + rev-0)) + (is (eql (identified-construct ii-2 :revision rev-1) top-1)) + (is-false (identified-construct ii-2 :revision rev-0-5)) + (is (eql (find-item-by-revision ii-2 rev-1 top-1) ii-2)))))) + + + (defun run-datamodel-tests() @@ -1962,4 +2094,8 @@ (it.bese.fiveam:run! 'test-find-item-by-revision) (it.bese.fiveam:run! 'test-make-Unknown) (it.bese.fiveam:run! 'test-make-VersionedConstructC) + (it.bese.fiveam:run! 'test-make-TopicIdentificationC) + (it.bese.fiveam:run! 'test-make-PersistentIdC) + (it.bese.fiveam:run! 'test-make-SubjectLocatorC) + (it.bese.fiveam:run! 'test-make-ItemIdentifierC) ) \ No newline at end of file

1 0

[isidorus-cvs] r247 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 22 Mar '10

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 14:49:05 2010 New Revision: 247 Log: new-datamodel: added some unit-test for "make-construct" --> "VersionedConstructC" and unknown class; fixed a problem in "make-construct" that appears when creating "VersionedConstructC"s 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 Mon Mar 22 14:49:05 2010 @@ -2692,6 +2692,9 @@ history accordingly. Returns the object in question. Methods use specific keyword arguments for their purpose." (declare (symbol class-symbol)) + (when (and (VersionedConstructC-p class-symbol) + (not (getf args :start-revision))) + (error "From make-construct(): start-revision must be set")) (let ((construct (cond ((PointerC-p class-symbol) @@ -2707,7 +2710,8 @@ ((AssociationC-p class-symbol) (apply #'make-association args)) ((VersionedConstructC-p class-symbol) - (apply #'make-instance (rec-remf args :start-revision))) + (apply #'make-instance class-symbol + (rec-remf args :start-revision))) (t (apply #'make-instance class-symbol args)))) (start-revision (getf args :start-revision))) @@ -2718,8 +2722,6 @@ (complete-scopable construct (getf args :themes) :start-revision start-revision)) (when (typep construct 'VersionedConstructC) - (unless start-revision - (error "From make-construct(): start-revision must be set")) (add-to-version-history construct :start-revision start-revision)) (if (typep construct 'ReifiableConstructC) (complete-reifiable construct (getf args :item-identtifiers) 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 Mon Mar 22 14:49:05 2010 @@ -59,7 +59,9 @@ :test-equivalent-TopicC :test-equivalent-TopicMapC :test-class-p - :test-find-item-by-revision)) + :test-find-item-by-revision + :test-make-Unknown + :test-make-VersionedConstructC)) ;;TODO: test make-construct @@ -1874,6 +1876,46 @@ +(test test-make-Unknown () + "Tests the function make-construct corresponding to an unknown class." + (defclass Unknown () + ((value :initarg :value + :accessor value))) + (let ((construct (make-construct 'Unknown :value "value"))) + (is-true construct) + (string= (value construct) "value"))) + + +(test test-make-VersionedConstructC () + "Tests the function make-construct corresponding to VersionedConstructC." + (with-fixture with-empty-db (*db-dir*) + (let ((psi-1 (make-instance 'PersistentIdC :uri "psi-1")) + (top-1 (make-instance 'TopicC)) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (let ((vc (make-construct 'VersionedConstructC + :start-revision rev-2)) + (psi-assoc (make-construct 'd::PersistentIdAssociationC + :start-revision rev-1 + :identifier psi-1 + :parent-construct top-1))) + (signals error (make-construct 'd::PersistentIdAssociationC + :start-revision rev-1 + :identifier psi-1)) + (signals error (make-construct 'VersionedConstructC)) + (is (= (length (d::versions vc)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-2) + (= (d::end-revision vi) rev-0))) + (d::versions vc))) + (is (= (length (d::versions psi-assoc)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-1) + (= (d::end-revision vi) rev-0))) + (d::versions psi-assoc))))))) + + (defun run-datamodel-tests() @@ -1918,4 +1960,6 @@ (it.bese.fiveam:run! 'test-equivalent-TopicMapC) (it.bese.fiveam:run! 'test-class-p) (it.bese.fiveam:run! 'test-find-item-by-revision) + (it.bese.fiveam:run! 'test-make-Unknown) + (it.bese.fiveam:run! 'test-make-VersionedConstructC) ) \ No newline at end of file

1 0

[isidorus-cvs] r246 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 22 Mar '10

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 14:14:02 2010 New Revision: 246 Log: replaced all keyword parameters of the form "(revision 0)" or "(start-revision 0)" to "(revision *TM-REVISION*)" and "(start-revision *TM-REVISION*)" to be compatible with the macro "with-revision" which uses the variable "*TM-REVISION*" 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 Mon Mar 22 14:14:02 2010 @@ -156,9 +156,6 @@ -;;TOOD: replace the key argument (revision 0)/(start-revision 0) -;; by (start-revision *TM-REVISION*) (revision *TM-REVISION*) -;; to be compatible to the macro with-revision ;;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), @@ -765,7 +762,7 @@ its parent-construct.")) -(defgeneric check-for-duplicate-identifiers (construct) +(defgeneric check-for-duplicate-identifiers (construct &key revision) (:documentation "Check for possibly duplicate identifiers and signal an duplicate-identifier-error is such duplicates are found")) @@ -926,8 +923,9 @@ ;;; TopicMapconstructC -(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)) - (declare (ignore construct)) +(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC) + &key revision) + (declare (ignorable revision construct)) ;do nothing ) @@ -1009,7 +1007,7 @@ (defgeneric identified-construct (construct &key revision) (:documentation "Returns the identified-construct -> ReifiableConstructC or TopicC that corresponds with the passed revision.") - (:method ((construct PointerC) &key (revision 0)) + (:method ((construct PointerC) &key (revision *TM-REVISION*)) (let ((assocs (map 'list #'parent-construct (filter-slot-value-by-revision construct 'identified-construct @@ -1218,7 +1216,7 @@ (= essentially the OID). If xtm-id is explicitly given, returns one of the topic-ids in that TM (which must then exist).") - (:method ((construct TopicC) &optional (xtm-id nil) (revision 0)) + (:method ((construct TopicC) &optional (xtm-id nil) (revision *TM-REVISION*)) (declare (type (or null string) xtm-id) (integer revision)) (if xtm-id (let ((possible-identifiers @@ -1240,7 +1238,7 @@ (defgeneric topic-identifiers (construct &key revision) (:documentation "Returns the TopicIdentificationC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'topic-identifiers :start-revision revision))) (map 'list #'identifier assocs)))) @@ -1257,7 +1255,8 @@ (let ((all-ids (map 'list #'identifier (slot-p construct 'topic-identifiers))) (construct-to-be-merged - (let ((id-owner (identified-construct topic-identifier))) + (let ((id-owner (identified-construct topic-identifier + :revision revision))) (when (not (eql id-owner construct)) id-owner)))) (let ((merged-construct construct)) @@ -1298,7 +1297,7 @@ (defgeneric psis (construct &key revision) (:documentation "Returns the PersistentIdC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'psis :start-revision revision))) (map 'list #'identifier assocs)))) @@ -1315,7 +1314,7 @@ (let ((all-ids (map 'list #'identifier (slot-p construct 'psis))) (construct-to-be-merged - (let ((id-owner (identified-construct psi))) + (let ((id-owner (identified-construct psi :revision revision))) (when (not (eql id-owner construct)) id-owner)))) (let ((merged-construct construct)) @@ -1354,7 +1353,7 @@ (defgeneric locators (construct &key revision) (:documentation "Returns the SubjectLocatorC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'locators :start-revision revision))) (map 'list #'identifier assocs)))) @@ -1371,7 +1370,7 @@ (let ((all-ids (map 'list #'identifier (slot-p construct 'locators))) (construct-to-be-merged - (let ((id-owner (identified-construct locator))) + (let ((id-owner (identified-construct locator :revision revision))) (when (not (eql id-owner construct)) id-owner)))) (let ((merged-construct construct)) @@ -1409,7 +1408,7 @@ (defmethod get-all-identifiers-of-construct ((construct TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (declare (integer revision)) (append (psis construct :revision revision) (locators construct :revision revision) @@ -1419,7 +1418,7 @@ (defgeneric names (construct &key revision) (:documentation "Returns the NameC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'names :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -1470,7 +1469,7 @@ (defgeneric occurrences (construct &key revision) (:documentation "Returns the OccurrenceC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'occurrences :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -1485,9 +1484,9 @@ (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision *TM-REVISION*)) (when (and (parent occurrence :revision revision) - (not (eql (parent occurrence) construct))) + (not (eql (parent occurrence :revision revision) construct))) (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" - occurrence construct (parent occurrence))) + occurrence construct (parent occurrence :revision revision))) (let ((all-occurrences (map 'list #'characteristic (slot-p construct 'occurrences)))) (if (find occurrence all-occurrences) @@ -1520,7 +1519,7 @@ (defgeneric player-in-roles (construct &key revision) (:documentation "Returns the RoleC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'player-in-roles :start-revision revision))) (map 'list #'parent-construct assocs)))) @@ -1529,7 +1528,7 @@ (defgeneric used-as-type (construct &key revision) (:documentation "Returns the TypableC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'used-as-type :start-revision revision))) (map 'list #'typable-construct assocs)))) @@ -1538,7 +1537,7 @@ (defgeneric used-as-theme (construct &key revision) (:documentation "Returns the ScopableC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'used-as-theme :start-revision revision))) (map 'list #'scopable-construct assocs)))) @@ -1547,18 +1546,19 @@ (defgeneric reified-construct (construct &key revision) (:documentation "Returns the ReifiableConstructC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'reified-construct :start-revision revision))) (when assocs (reifiable-construct (first assocs)))))) -(defmethod in-topicmaps ((topic TopicC) &key (revision 0)) +(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) -(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) (revision 0) (error-if-nil nil)) +(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) + (revision *TM-REVISION*) (error-if-nil nil)) "Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM is chosen. If xtm-id is nil, choose the global TM with its internal ID, if applicable in the correct revision. If revison is provided, then the code checks @@ -1580,7 +1580,8 @@ 'uri topic-id)))) (when (and possible-top-ids - (identified-construct (first possible-top-ids) :revision revision)) + (identified-construct (first possible-top-ids) + :revision revision)) (unless (= (length possible-top-ids) 1) (error (make-condition 'duplicate-identifier-error @@ -1606,7 +1607,7 @@ result))) -(defun get-item-by-identifier (uri &key (revision 0) +(defun get-item-by-identifier (uri &key (revision *TM-REVISION*) (identifier-type-symbol 'PersistentIdC) (error-if-nil nil)) "Returns the construct that is bound to the given identifier-uri." @@ -1618,7 +1619,8 @@ (string= (uri id) uri)) (get-instances-by-value identifier-type-symbol 'uri uri)))) (when (and possible-ids - (identified-construct (first possible-ids) :revision revision)) + (identified-construct (first possible-ids) + :revision revision)) (unless (= (length possible-ids) 1) (error (make-condition 'duplicate-identifier-error :message (format nil "(length possible-items ~a) for id ~a" @@ -1634,21 +1636,22 @@ (error "No such item is bound to the given identifier uri."))))) -(defun get-item-by-item-identifier (uri &key (revision 0) (error-if-nil nil)) +(defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*) + (error-if-nil nil)) "Returns a ReifiableConstructC that is bound to the identifier-uri." (get-item-by-identifier uri :revision revision :identifier-type-symbol 'ItemIdentifierC :error-if-nil error-if-nil)) -(defun get-item-by-psi (uri &key (revision 0) (error-if-nil nil)) +(defun get-item-by-psi (uri &key (revision *TM-REVISION*) (error-if-nil nil)) "Returns a TopicC that is bound to the identifier-uri." (get-item-by-identifier uri :revision revision :identifier-type-symbol 'PersistentIdC :error-if-nil error-if-nil)) -(defun get-item-by-locator (uri &key (revision 0) (error-if-nil nil)) +(defun get-item-by-locator (uri &key (revision *TM-REVISION*) (error-if-nil nil)) "Returns a TopicC that is bound to the identifier-uri." (get-item-by-identifier uri :revision revision :identifier-type-symbol 'SubjectLocatorC @@ -1658,7 +1661,7 @@ (defgeneric list-instanceOf (topic &key tm revision) (:documentation "Generates a list of all topics that this topic is an instance of, optionally filtered by a topic map") - (:method ((topic TopicC) &key (tm nil) (revision 0)) + (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*)) (declare (type (or null TopicMapC) tm) (integer revision)) (remove-if @@ -1676,7 +1679,8 @@ (if tm (remove-if-not (lambda (role) - (in-topicmap tm (parent role :revision revision))) + (in-topicmap tm (parent role :revision revision) + :revision revision)) (player-in-roles topic :revision revision)) (player-in-roles topic :revision revision)))))) @@ -1684,7 +1688,7 @@ (defgeneric list-super-types (topic &key tm revision) (:documentation "Generate a list of all topics that this topic is an subclass of, optionally filtered by a topic map") - (:method ((topic TopicC) &key (tm nil) (revision 0)) + (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*)) (declare (type (or null TopicMapC) tm) (integer revision)) (remove-if @@ -1702,7 +1706,8 @@ (if tm (remove-if-not (lambda (role) - (in-topicmap tm (parent role :revision revision))) + (in-topicmap tm (parent role :revision revision) + :revision revision)) (player-in-roles topic :revision revision)) (player-in-roles topic :revision revision)))))) @@ -1719,8 +1724,8 @@ (defmethod equivalent-construct ((construct CharacteristicC) - &key (start-revision 0) (charvalue "") - (instance-of nil) (themes nil)) + &key (start-revision *TM-REVISION*) + (charvalue "") (instance-of nil) (themes nil)) "Equality rule: Characteristics are equal if charvalue, themes and instance-of are equal." (declare (string charvalue) (list themes) @@ -1778,7 +1783,7 @@ (:documentation "Returns the parent construct of the passed object that corresponds with the given revision. The returned construct can be a TopicC or a NameC.") - (:method ((construct CharacteristicC) &key (revision 0)) + (:method ((construct CharacteristicC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'parent :start-revision revision))) @@ -1845,15 +1850,15 @@ (defmethod equivalent-construct ((construct OccurrenceC) - &key (start-revision 0) (charvalue "") - (themes nil) (instance-of nil) + &key (start-revision *TM-REVISION*) + (charvalue "") (themes nil) (instance-of nil) (datatype "")) "Occurrences are equal if their charvalue, datatype, themes and instance-of properties are equal." (declare (type (or null TopicC) instance-of) (string datatype) (ignorable start-revision charvalue themes instance-of)) (let ((equivalent-characteristic (call-next-method))) - ;; item-identifiers and reifers are not checked because the equality have to + ;; item-identifiers and reifers are not checked because the equaity have to ;; be variafied without them (and equivalent-characteristic (string= (datatype construct) datatype)))) @@ -1867,8 +1872,8 @@ (defmethod equivalent-construct ((construct VariantC) - &key (start-revision 0) (charvalue "") - (themes nil) (datatype "")) + &key (start-revision *TM-REVISION*) + (charvalue "") (themes nil) (datatype "")) "Variants are equal if their charvalue, datatype and themes properties are equal." (declare (string datatype) (ignorable start-revision charvalue themes)) @@ -1902,8 +1907,8 @@ (defmethod equivalent-construct ((construct NameC) - &key (start-revision 0) (charvalue "") - (themes nil) (instance-of nil)) + &key (start-revision *TM-REVISION*) + (charvalue "") (themes nil) (instance-of nil)) "Names are equal if their charvalue, instance-of and themes properties are equal." (declare (type (or null TopicC) instance-of) @@ -1924,7 +1929,7 @@ (defgeneric variants (construct &key revision) (:documentation "Returns all variants that correspond with the given revision and that are associated with the passed construct.") - (:method ((construct NameC) &key (revision 0)) + (:method ((construct NameC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'variants :start-revision revision))) @@ -1939,7 +1944,7 @@ (when (and (parent variant :revision revision) (not (eql (parent variant :revision revision) construct))) (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" - variant construct (parent variant))) + variant construct (parent variant :revision revision))) (let ((all-variants (map 'list #'characteristic (slot-p construct 'variants)))) (if (find variant all-variants) @@ -1977,8 +1982,8 @@ (defmethod equivalent-construct ((construct AssociationC) - &key (start-revision 0) (roles nil) - (instance-of nil) (themes nil)) + &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." (declare (integer start-revision) (list roles themes) @@ -2013,7 +2018,7 @@ (defgeneric roles (construct &key revision) (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") - (:method ((construct AssociationC) &key (revision 0)) + (:method ((construct AssociationC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'roles :start-revision revision))) @@ -2054,7 +2059,7 @@ construct))) -(defmethod in-topicmaps ((association AssociationC) &key (revision 0)) +(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) @@ -2066,8 +2071,8 @@ (defmethod equivalent-construct ((construct RoleC) - &key (start-revision 0) (player nil) - (instance-of nil)) + &key (start-revision *TM-REVISION*) + (player nil) (instance-of nil)) "Roles are equal if their instance-of and player properties are equal." (declare (integer start-revision) (type (or null TopicC) player instance-of)) ;; item-identifiers and reifers are not checked because the equality have to @@ -2124,7 +2129,7 @@ t)) -(defmethod parent ((construct RoleC) &key (revision 0)) +(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*)) "Returns the construct's parent corresponding to the given revision." (let ((valid-associations (filter-slot-value-by-revision construct 'parent @@ -2176,7 +2181,7 @@ (defgeneric player (construct &key revision) (:documentation "Returns the construct's player corresponding to the given revision.") - (:method ((construct RoleC) &key (revision 0)) + (:method ((construct RoleC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'player :start-revision revision))) @@ -2228,8 +2233,10 @@ ;;; ReifiableConstructC -(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)) - (dolist (id (get-all-identifiers-of-construct construct)) +(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (dolist (id (get-all-identifiers-of-construct construct :revision revision)) (when (> (length (union @@ -2281,7 +2288,7 @@ the reifiable construct have to share an item identifier or reifier.") (:method ((construct ReifiableConstructC) reifier item-identifiers - &key (start-revision 0)) + &key (start-revision *TM-REVISION*)) (declare (integer start-revision) (list item-identifiers) (type (or null TopicC) reifier)) (or (and (reifier construct :revision start-revision) @@ -2306,7 +2313,7 @@ (defgeneric item-identifiers (construct &key revision) (:documentation "Returns the ItemIdentifierC-objects that correspond with the passed construct and the passed version.") - (:method ((construct ReifiableConstructC) &key (revision 0)) + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) (map 'list #'identifier assocs)))) @@ -2315,7 +2322,7 @@ (defgeneric reifier (construct &key revision) (:documentation "Returns the reifier-topic that corresponds with the passed construct and the passed version.") - (:method ((construct ReifiableConstructC) &key (revision 0)) + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'reifier :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item @@ -2333,7 +2340,8 @@ (let ((all-ids (map 'list #'identifier (slot-p construct 'item-identifiers))) (construct-to-be-merged - (let ((id-owner (identified-construct item-identifier))) + (let ((id-owner (identified-construct item-identifier + :revision revision))) (when (not (eql id-owner construct)) id-owner)))) (let ((merged-construct construct)) @@ -2381,8 +2389,9 @@ (:method ((construct ReifiableConstructC) (reifier-topic TopicC) &key (revision *TM-REVISION*)) (let ((merged-reifier-topic - (if (reifier construct) - (merge-constructs (reifier construct) reifier-topic) + (if (reifier construct :revision revision) + (merge-constructs (reifier construct :revision revision) + reifier-topic) reifier-topic))) (let ((all-constructs (let ((inner-construct (reified-construct merged-reifier-topic @@ -2427,7 +2436,7 @@ (defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (declare (integer revision)) (item-identifiers construct :revision revision)) @@ -2457,7 +2466,7 @@ &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. the typable constructs have to own the same type.") - (:method ((construct TypableC) instance-of &key (start-revision 0)) + (:method ((construct TypableC) instance-of &key (start-revision *TM-REVISION*)) (declare (integer start-revision) (type (or null TopicC) instance-of)) (eql (instance-of construct :revision start-revision) instance-of))) @@ -2486,7 +2495,7 @@ (defgeneric equivalent-scopable-construct (construct themes &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. the scopable constructs have to own the same themes.") - (:method ((construct ScopableC) themes &key (start-revision 0)) + (:method ((construct ScopableC) themes &key (start-revision *TM-REVISION*)) (declare (integer start-revision) (list themes)) (not (set-exclusive-or (themes construct :revision start-revision) themes)))) @@ -2500,7 +2509,7 @@ (defgeneric themes (construct &key revision) (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") - (:method ((construct ScopableC) &key (revision 0)) + (:method ((construct ScopableC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'themes :start-revision revision))) @@ -2561,7 +2570,7 @@ (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed revision.") - (:method ((construct TypableC) &key (revision 0)) + (:method ((construct TypableC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'instance-of :start-revision revision))) @@ -2626,8 +2635,8 @@ (defmethod equivalent-construct ((construct TopicMapC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil)) + &key (start-revision *TM-REVISION*) + (reifier nil) (item-identifiers nil)) "TopicMaps equality if they share the same item-identier or reifier." (declare (list item-identifiers) (integer start-revision) (type (or null TopicC) reifier)) @@ -2664,12 +2673,14 @@ topic map?")) -(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0)) +(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key + (revision *TM-REVISION*)) (when (find-item-by-revision top revision) (find (internal-id top) (topics tm) :test #'= :key #'internal-id))) -(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0)) +(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) + &key (revision *TM-REVISION*)) (when (find-item-by-revision ass revision) (find (internal-id ass) (associations tm) :test #'= :key #'internal-id))) 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 Mon Mar 22 14:14:02 2010 @@ -417,44 +417,51 @@ (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) (top-3 (make-instance 'TopicC)) - (revision 100) - (revision-2 200)) - (setf d:*TM-REVISION* revision) - (is-false (get-item-by-id "any-top-id")) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (setf d:*TM-REVISION* rev-1) + (is-false (get-item-by-id "any-top-id" :revision rev-0)) (signals error (is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id" :error-if-nil t))) - (signals error (is-false (get-item-by-id "any-top-id" :error-if-nil t))) + (signals error (is-false (get-item-by-id "any-top-id" :error-if-nil t + :revision rev-0))) (is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id")) - (add-topic-identifier top-1 top-id-3-1 :revision revision) - (add-topic-identifier top-1 top-id-3-2 :revision revision) + (add-topic-identifier top-1 top-id-3-1 :revision rev-1) + (add-topic-identifier top-1 top-id-3-2 :revision rev-1) (signals duplicate-identifier-error - (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision revision)) + (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision rev-1)) (add-topic-identifier top-2 top-id-1) - (add-topic-identifier top-2 top-id-2 :revision revision-2) - (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"))) - (is (eql top-2 (get-item-by-id "topid-2" :xtm-id "xtm-id-2"))) + (add-topic-identifier top-2 top-id-2 :revision rev-2) + (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision rev-0))) + (is (eql top-2 (get-item-by-id "topid-2" :xtm-id "xtm-id-2" + :revision rev-0))) (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" :revision 500))) (is-false (get-item-by-id "topid-2" :xtm-id "xtm-id-2" - :revision revision)) - (delete-topic-identifier top-2 top-id-1 :revision revision-2) - (is-false (get-item-by-id "topid-1" :xtm-id "xtm-id-1")) + :revision rev-1)) + (delete-topic-identifier top-2 top-id-1 :revision rev-2) + (is-false (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision rev-0)) (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" - :revision revision))) - (add-topic-identifier top-3 top-id-1 :revision revision-2) + :revision rev-1))) + (add-topic-identifier top-3 top-id-1 :revision rev-2) (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" - :revision revision))) - (d::add-to-version-history top-3 :start-revision revision-2) - (is (eql top-3 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"))) + :revision rev-1))) + (d::add-to-version-history top-3 :start-revision rev-2) + (is (eql top-3 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision rev-0))) (is (eql top-3 (get-item-by-id (concatenate 'string "t" (write-to-string - (elephant::oid top-3)))))) + (elephant::oid top-3))) + :revision rev-0))) (is-false (get-item-by-id (concatenate 'string "t" (write-to-string (elephant::oid top-3))) - :revision revision))))) + :revision rev-1))))) (test test-get-item-by-item-identifier () @@ -471,32 +478,35 @@ (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) (top-3 (make-instance 'TopicC)) - (revision 100) - (revision-2 200)) - (setf d:*TM-REVISION* revision) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-ii-id")) (signals error (is-false (get-item-by-item-identifier - "any-ii-id" :error-if-nil t))) + "any-ii-id" :error-if-nil t + :revision rev-1))) (signals error (is-false (get-item-by-item-identifier - "any-ii-id" :error-if-nil t))) + "any-ii-id" :error-if-nil t + :revision rev-1))) (is-false (get-item-by-item-identifier "any-ii-id")) - (add-item-identifier top-1 ii-3-1 :revision revision) - (add-item-identifier top-1 ii-3-2 :revision revision) + (add-item-identifier top-1 ii-3-1 :revision rev-1) + (add-item-identifier top-1 ii-3-2 :revision rev-1) (signals duplicate-identifier-error - (get-item-by-item-identifier "ii-3" :revision revision)) + (get-item-by-item-identifier "ii-3" :revision rev-1)) (add-item-identifier top-2 ii-1) - (add-item-identifier top-2 ii-2 :revision revision-2) - (is (eql top-2 (get-item-by-item-identifier "ii-1"))) - (is (eql top-2 (get-item-by-item-identifier "ii-2"))) + (add-item-identifier top-2 ii-2 :revision rev-2) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-0))) + (is (eql top-2 (get-item-by-item-identifier "ii-2" :revision rev-0))) (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision 500))) - (is-false (get-item-by-item-identifier "ii-2" :revision revision)) - (delete-item-identifier top-2 ii-1 :revision revision-2) - (is-false (get-item-by-item-identifier "ii-1")) - (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision revision))) - (add-item-identifier top-3 ii-1 :revision revision-2) - (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision revision))) - (d::add-to-version-history top-3 :start-revision revision-2) - (is (eql top-3 (get-item-by-item-identifier "ii-1")))))) + (is-false (get-item-by-item-identifier "ii-2" :revision rev-1)) + (delete-item-identifier top-2 ii-1 :revision rev-2) + (is-false (get-item-by-item-identifier "ii-1" :revision rev-0)) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-1))) + (add-item-identifier top-3 ii-1 :revision rev-2) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-1))) + (d::add-to-version-history top-3 :start-revision rev-2) + (is (eql top-3 (get-item-by-item-identifier "ii-1" :revision rev-0)))))) (test test-get-item-by-locator () @@ -513,32 +523,35 @@ (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) (top-3 (make-instance 'TopicC)) - (revision 100) - (revision-2 200)) - (setf d:*TM-REVISION* revision) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-sl-id")) (signals error (is-false (get-item-by-locator - "any-sl-id" :error-if-nil t))) + "any-sl-id" :error-if-nil t + :revision rev-0))) (signals error (is-false (get-item-by-locator - "any-sl-id" :error-if-nil t))) - (is-false (get-item-by-locator "any-sl-id")) - (add-locator top-1 sl-3-1 :revision revision) - (add-locator top-1 sl-3-2 :revision revision) + "any-sl-id" :error-if-nil t + :revision rev-0))) + (is-false (get-item-by-locator "any-sl-id" :revision rev-0)) + (add-locator top-1 sl-3-1 :revision rev-1) + (add-locator top-1 sl-3-2 :revision rev-1) (signals duplicate-identifier-error - (get-item-by-locator "sl-3" :revision revision)) + (get-item-by-locator "sl-3" :revision rev-1)) (add-locator top-2 sl-1) - (add-locator top-2 sl-2 :revision revision-2) - (is (eql top-2 (get-item-by-locator "sl-1"))) - (is (eql top-2 (get-item-by-locator "sl-2"))) + (add-locator top-2 sl-2 :revision rev-2) + (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-0))) + (is (eql top-2 (get-item-by-locator "sl-2" :revision rev-0))) (is (eql top-2 (get-item-by-locator "sl-1" :revision 500))) - (is-false (get-item-by-locator "sl-2" :revision revision)) - (delete-locator top-2 sl-1 :revision revision-2) - (is-false (get-item-by-locator "sl-1")) - (is (eql top-2 (get-item-by-locator "sl-1" :revision revision))) - (add-locator top-3 sl-1 :revision revision-2) - (is (eql top-2 (get-item-by-locator "sl-1" :revision revision))) - (d::add-to-version-history top-3 :start-revision revision-2) - (is (eql top-3 (get-item-by-locator "sl-1")))))) + (is-false (get-item-by-locator "sl-2" :revision rev-1)) + (delete-locator top-2 sl-1 :revision rev-2) + (is-false (get-item-by-locator "sl-1" :revision rev-0)) + (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-1))) + (add-locator top-3 sl-1 :revision rev-2) + (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-1))) + (d::add-to-version-history top-3 :start-revision rev-2) + (is (eql top-3 (get-item-by-locator "sl-1" :revision rev-0)))))) (test test-get-item-by-psi () @@ -555,32 +568,35 @@ (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) (top-3 (make-instance 'TopicC)) - (revision 100) - (revision-2 200)) - (setf d:*TM-REVISION* revision) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-psi-id")) (signals error (is-false (get-item-by-locator - "any-psi-id" :error-if-nil t))) + "any-psi-id" :error-if-nil t + :revision rev-0))) (signals error (is-false (get-item-by-locator - "any-psi-id" :error-if-nil t))) + "any-psi-id" :error-if-nil t + :revision rev-0))) (is-false (get-item-by-locator "any-psi-id")) - (add-psi top-1 psi-3-1 :revision revision) - (add-psi top-1 psi-3-2 :revision revision) + (add-psi top-1 psi-3-1 :revision rev-1) + (add-psi top-1 psi-3-2 :revision rev-1) (signals duplicate-identifier-error - (get-item-by-locator "psi-3" :revision revision)) + (get-item-by-locator "psi-3" :revision rev-1)) (add-psi top-2 psi-1) - (add-psi top-2 psi-2 :revision revision-2) - (is (eql top-2 (get-item-by-locator "psi-1"))) - (is (eql top-2 (get-item-by-locator "psi-2"))) + (add-psi top-2 psi-2 :revision rev-2) + (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-0))) + (is (eql top-2 (get-item-by-locator "psi-2" :revision rev-0))) (is (eql top-2 (get-item-by-locator "psi-1" :revision 500))) - (is-false (get-item-by-locator "psi-2" :revision revision)) - (delete-psi top-2 psi-1 :revision revision-2) - (is-false (get-item-by-locator "psi-1")) - (is (eql top-2 (get-item-by-locator "psi-1" :revision revision))) - (add-psi top-3 psi-1 :revision revision-2) - (is (eql top-2 (get-item-by-locator "psi-1" :revision revision))) - (d::add-to-version-history top-3 :start-revision revision-2) - (is (eql top-3 (get-item-by-locator "psi-1")))))) + (is-false (get-item-by-locator "psi-2" :revision rev-1)) + (delete-psi top-2 psi-1 :revision rev-2) + (is-false (get-item-by-locator "psi-1" :revision rev-0)) + (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1))) + (add-psi top-3 psi-1 :revision rev-2) + (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1))) + (d::add-to-version-history top-3 :start-revision rev-2) + (is (eql top-3 (get-item-by-locator "psi-1" :revision rev-0)))))) (test test-ReifiableConstructC () @@ -621,81 +637,82 @@ (occ-2 (make-instance 'OccurrenceC)) (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) - (revision-1 100) - (revision-2 200) - (revision-3 300) - (revision-4 400) - (revision-5 500) - (revision-6 600) - (revision-7 700) - (revision-8 800)) - (setf *TM-REVISION* revision-1) - (is-false (parent occ-1)) - (is-false (occurrences top-1)) - (add-occurrence top-1 occ-1 :revision revision-1) + (rev-0 0) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (rev-5 500) + (rev-6 600) + (rev-7 700) + (rev-8 800)) + (setf *TM-REVISION* rev-1) + (is-false (parent occ-1 :revision rev-0)) + (is-false (occurrences top-1 :revision rev-0)) + (add-occurrence top-1 occ-1 :revision rev-1) (is (= (length (d::versions top-1)) 1)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-1) + (and (= (d::start-revision vi) rev-1) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list occ-1) - (occurrences top-1))) 1)) - (add-occurrence top-1 occ-2 :revision revision-2) + (occurrences top-1 :revision rev-0))) 1)) + (add-occurrence top-1 occ-2 :revision rev-2) (is (= (length (d::versions top-1)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-2) + (and (= (d::start-revision vi) rev-2) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list occ-1 occ-2) - (occurrences top-1))) 2)) + (occurrences top-1 :revision rev-0))) 2)) (is (= (length (union (list occ-1) - (occurrences top-1 :revision revision-1))) 1)) - (add-occurrence top-1 occ-2 :revision revision-3) + (occurrences top-1 :revision rev-1))) 1)) + (add-occurrence top-1 occ-2 :revision rev-3) (is (= (length (d::slot-p top-1 'd::occurrences)) 2)) - (delete-occurrence top-1 occ-1 :revision revision-4) + (delete-occurrence top-1 occ-1 :revision rev-4) (is (= (length (d::versions top-1)) 4)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-4) + (and (= (d::start-revision vi) rev-4) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list occ-2) - (occurrences top-1 :revision revision-4))) 1)) + (occurrences top-1 :revision rev-4))) 1)) (is (= (length (union (list occ-2) - (occurrences top-1))) 1)) + (occurrences top-1 :revision rev-0))) 1)) (is (= (length (union (list occ-1 occ-2) - (occurrences top-1 :revision revision-2))) 2)) - (add-occurrence top-1 occ-1 :revision revision-4) + (occurrences top-1 :revision rev-2))) 2)) + (add-occurrence top-1 occ-1 :revision rev-4) (is (= (length (union (list occ-2 occ-1) - (occurrences top-1))) 2)) - (signals error (add-occurrence top-2 occ-1 :revision revision-4)) - (delete-occurrence top-1 occ-1 :revision revision-5) + (occurrences top-1 :revision rev-0))) 2)) + (signals error (add-occurrence top-2 occ-1 :revision rev-4)) + (delete-occurrence top-1 occ-1 :revision rev-5) (is (= (length (union (list occ-2) - (occurrences top-1 :revision revision-5))) 1)) - (add-occurrence top-2 occ-1 :revision revision-5) - (is (eql (parent occ-1) top-2)) - (is (eql (parent occ-1 :revision revision-2) top-1)) - (delete-parent occ-2 top-1 :revision revision-4) - (is-false (parent occ-2 :revision revision-4)) - (is (eql top-1 (parent occ-2 :revision revision-3))) - (add-parent occ-2 top-1 :revision revision-5) - (is-false (parent occ-2 :revision revision-4)) - (is (eql top-1 (parent occ-2))) - (delete-parent occ-2 top-1 :revision revision-6) - (add-parent occ-2 top-2 :revision revision-7) + (occurrences top-1 :revision rev-5))) 1)) + (add-occurrence top-2 occ-1 :revision rev-5) + (is (eql (parent occ-1 :revision rev-0) top-2)) + (is (eql (parent occ-1 :revision rev-2) top-1)) + (delete-parent occ-2 top-1 :revision rev-4) + (is-false (parent occ-2 :revision rev-4)) + (is (eql top-1 (parent occ-2 :revision rev-3))) + (add-parent occ-2 top-1 :revision rev-5) + (is-false (parent occ-2 :revision rev-4)) + (is (eql top-1 (parent occ-2 :revision rev-0))) + (delete-parent occ-2 top-1 :revision rev-6) + (add-parent occ-2 top-2 :revision rev-7) (is (= (length (d::versions top-2)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-7) + (and (= (d::start-revision vi) rev-7) (= (d::end-revision vi) 0))) (d::versions top-2))) - (delete-parent occ-2 top-2 :revision revision-8) + (delete-parent occ-2 top-2 :revision rev-8) (is (= (length (d::versions top-2)) 3)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-8) + (and (= (d::start-revision vi) rev-8) (= (d::end-revision vi) 0))) (d::versions top-2))) - (is-false (parent occ-2)) - (add-parent occ-2 top-1 :revision revision-8) - (is (eql top-1 (parent occ-2)))))) + (is-false (parent occ-2 :revision rev-0)) + (add-parent occ-2 top-1 :revision rev-8) + (is (eql top-1 (parent occ-2 :revision rev-0)))))) (test test-VariantC () @@ -705,56 +722,57 @@ (v-2 (make-instance 'VariantC)) (name-1 (make-instance 'NameC)) (name-2 (make-instance 'NameC)) - (revision-1 100) - (revision-2 200) - (revision-3 300) - (revision-4 400) - (revision-5 500) - (revision-6 600) - (revision-7 700) - (revision-8 800)) - (setf *TM-REVISION* revision-1) - (is-false (parent v-1)) - (is-false (variants name-1)) - (add-variant name-1 v-1 :revision revision-1) + (rev-0 0) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (rev-5 500) + (rev-6 600) + (rev-7 700) + (rev-8 800)) + (setf *TM-REVISION* rev-1) + (is-false (parent v-1 :revision rev-0)) + (is-false (variants name-1 :revision rev-0)) + (add-variant name-1 v-1 :revision rev-1) (is (= (length (union (list v-1) - (variants name-1))) 1)) - (add-variant name-1 v-2 :revision revision-2) + (variants name-1 :revision rev-0))) 1)) + (add-variant name-1 v-2 :revision rev-2) (is (= (length (union (list v-1 v-2) - (variants name-1))) 2)) + (variants name-1 :revision rev-0))) 2)) (is (= (length (union (list v-1) - (variants name-1 :revision revision-1))) 1)) - (add-variant name-1 v-2 :revision revision-3) + (variants name-1 :revision rev-1))) 1)) + (add-variant name-1 v-2 :revision rev-3) (is (= (length (d::slot-p name-1 'd::variants)) 2)) - (delete-variant name-1 v-1 :revision revision-4) + (delete-variant name-1 v-1 :revision rev-4) (is (= (length (union (list v-2) - (variants name-1 :revision revision-4))) 1)) + (variants name-1 :revision rev-4))) 1)) (is (= (length (union (list v-2) - (variants name-1))) 1)) + (variants name-1 :revision rev-0))) 1)) (is (= (length (union (list v-1 v-2) - (variants name-1 :revision revision-2))) 2)) - (add-variant name-1 v-1 :revision revision-4) + (variants name-1 :revision rev-2))) 2)) + (add-variant name-1 v-1 :revision rev-4) (is (= (length (union (list v-2 v-1) - (variants name-1))) 2)) - (signals error (add-variant name-2 v-1 :revision revision-4)) - (delete-variant name-1 v-1 :revision revision-5) + (variants name-1 :revision rev-0))) 2)) + (signals error (add-variant name-2 v-1 :revision rev-4)) + (delete-variant name-1 v-1 :revision rev-5) (is (= (length (union (list v-2) - (variants name-1 :revision revision-5))) 1)) - (add-variant name-2 v-1 :revision revision-5) - (is (eql (parent v-1) name-2)) - (is (eql (parent v-1 :revision revision-2) name-1)) - (delete-parent v-2 name-1 :revision revision-4) - (is-false (parent v-2 :revision revision-4)) - (is (eql name-1 (parent v-2 :revision revision-3))) - (add-parent v-2 name-1 :revision revision-5) - (is-false (parent v-2 :revision revision-4)) - (is (eql name-1 (parent v-2))) - (delete-parent v-2 name-1 :revision revision-6) - (add-parent v-2 name-2 :revision revision-7) - (delete-parent v-2 name-2 :revision revision-8) - (is-false (parent v-2)) - (add-parent v-2 name-1 :revision revision-8) - (is (eql name-1 (parent v-2)))))) + (variants name-1 :revision rev-5))) 1)) + (add-variant name-2 v-1 :revision rev-5) + (is (eql (parent v-1 :revision rev-0) name-2)) + (is (eql (parent v-1 :revision rev-2) name-1)) + (delete-parent v-2 name-1 :revision rev-4) + (is-false (parent v-2 :revision rev-4)) + (is (eql name-1 (parent v-2 :revision rev-3))) + (add-parent v-2 name-1 :revision rev-5) + (is-false (parent v-2 :revision rev-4)) + (is (eql name-1 (parent v-2 :revision rev-0))) + (delete-parent v-2 name-1 :revision rev-6) + (add-parent v-2 name-2 :revision rev-7) + (delete-parent v-2 name-2 :revision rev-8) + (is-false (parent v-2 :revision rev-0)) + (add-parent v-2 name-1 :revision rev-8) + (is (eql name-1 (parent v-2 :revision rev-0)))))) (test test-NameC () @@ -764,81 +782,82 @@ (name-2 (make-instance 'NameC)) (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) - (revision-1 100) - (revision-2 200) - (revision-3 300) - (revision-4 400) - (revision-5 500) - (revision-6 600) - (revision-7 700) - (revision-8 800)) - (setf *TM-REVISION* revision-1) - (is-false (parent name-1)) - (is-false (names top-1)) - (add-name top-1 name-1 :revision revision-1) + (rev-0 0) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (rev-5 500) + (rev-6 600) + (rev-7 700) + (rev-8 800)) + (setf *TM-REVISION* rev-1) + (is-false (parent name-1 :revision rev-0)) + (is-false (names top-1 :revision rev-0)) + (add-name top-1 name-1 :revision rev-1) (is (= (length (d::versions top-1)) 1)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-1) + (and (= (d::start-revision vi) rev-1) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list name-1) - (names top-1))) 1)) - (add-name top-1 name-2 :revision revision-2) + (names top-1 :revision rev-0))) 1)) + (add-name top-1 name-2 :revision rev-2) (is (= (length (d::versions top-1)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-2) + (and (= (d::start-revision vi) rev-2) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list name-1 name-2) - (names top-1))) 2)) + (names top-1 :revision rev-0))) 2)) (is (= (length (union (list name-1) - (names top-1 :revision revision-1))) 1)) - (add-name top-1 name-2 :revision revision-3) + (names top-1 :revision rev-1))) 1)) + (add-name top-1 name-2 :revision rev-3) (is (= (length (d::slot-p top-1 'd::names)) 2)) - (delete-name top-1 name-1 :revision revision-4) + (delete-name top-1 name-1 :revision rev-4) (is (= (length (d::versions top-1)) 4)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-4) + (and (= (d::start-revision vi) rev-4) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list name-2) - (names top-1 :revision revision-4))) 1)) + (names top-1 :revision rev-4))) 1)) (is (= (length (union (list name-2) - (names top-1))) 1)) + (names top-1 :revision rev-0))) 1)) (is (= (length (union (list name-1 name-2) - (names top-1 :revision revision-2))) 2)) - (add-name top-1 name-1 :revision revision-4) + (names top-1 :revision rev-2))) 2)) + (add-name top-1 name-1 :revision rev-4) (is (= (length (union (list name-2 name-1) - (names top-1))) 2)) - (signals error (add-name top-2 name-1 :revision revision-4)) - (delete-name top-1 name-1 :revision revision-5) + (names top-1 :revision rev-0))) 2)) + (signals error (add-name top-2 name-1 :revision rev-4)) + (delete-name top-1 name-1 :revision rev-5) (is (= (length (union (list name-2) - (names top-1 :revision revision-5))) 1)) - (add-name top-2 name-1 :revision revision-5) - (is (eql (parent name-1) top-2)) - (is (eql (parent name-1 :revision revision-2) top-1)) - (delete-parent name-2 top-1 :revision revision-4) - (is-false (parent name-2 :revision revision-4)) - (is (eql top-1 (parent name-2 :revision revision-3))) - (add-parent name-2 top-1 :revision revision-5) - (is-false (parent name-2 :revision revision-4)) - (is (eql top-1 (parent name-2))) - (delete-parent name-2 top-1 :revision revision-6) - (add-parent name-2 top-2 :revision revision-7) + (names top-1 :revision rev-5))) 1)) + (add-name top-2 name-1 :revision rev-5) + (is (eql (parent name-1 :revision rev-0) top-2)) + (is (eql (parent name-1 :revision rev-2) top-1)) + (delete-parent name-2 top-1 :revision rev-4) + (is-false (parent name-2 :revision rev-4)) + (is (eql top-1 (parent name-2 :revision rev-3))) + (add-parent name-2 top-1 :revision rev-5) + (is-false (parent name-2 :revision rev-4)) + (is (eql top-1 (parent name-2 :revision rev-0))) + (delete-parent name-2 top-1 :revision rev-6) + (add-parent name-2 top-2 :revision rev-7) (is (= (length (d::versions top-2)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-7) + (and (= (d::start-revision vi) rev-7) (= (d::end-revision vi) 0))) (d::versions top-2))) - (delete-parent name-2 top-2 :revision revision-8) + (delete-parent name-2 top-2 :revision rev-8) (is (= (length (d::versions top-2)) 3)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-8) + (and (= (d::start-revision vi) rev-8) (= (d::end-revision vi) 0))) (d::versions top-2))) - (is-false (parent name-2)) - (add-parent name-2 top-1 :revision revision-8) - (is (eql top-1 (parent name-2)))))) + (is-false (parent name-2 :revision rev-0)) + (add-parent name-2 top-1 :revision rev-8) + (is (eql top-1 (parent name-2 :revision rev-0)))))) (test test-TypableC () @@ -848,31 +867,31 @@ (name-2 (make-instance 'NameC)) (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) + (revision-0 0) (revision-0-5 50) (revision-1 100) (revision-2 200) (revision-3 300)) (setf *TM-REVISION* revision-1) - (is-false (instance-of name-1)) + (is-false (instance-of name-1 :revision revision-0)) (add-type name-1 top-1) (is (eql top-1 (instance-of name-1))) (is-false (instance-of name-1 :revision revision-0-5)) (is (eql top-1 (instance-of name-1 :revision revision-2))) - (signals error (add-type name-1 top-2)) + (signals error (add-type name-1 top-2 :revision revision-0)) (add-type name-2 top-1 :revision revision-2) (is (= (length (union (list name-1 name-2) - (used-as-type top-1))) 2)) + (used-as-type top-1 :revision revision-0))) 2)) (is (= (length (union (list name-1) - (used-as-type top-1 - :revision revision-1))) 1)) + (used-as-type top-1 :revision revision-1))) 1)) (delete-type name-1 top-1 :revision revision-3) - (is-false (instance-of name-1)) + (is-false (instance-of name-1 :revision revision-0)) (is (= (length (union (list name-2) - (used-as-type top-1))) 1)) + (used-as-type top-1 :revision revision-0))) 1)) (add-type name-1 top-1 :revision revision-3) - (is (eql top-1 (instance-of name-1))) + (is (eql top-1 (instance-of name-1 :revision revision-0))) (is (= (length (union (list name-1 name-2) - (used-as-type top-1))) 2)) + (used-as-type top-1 :revision revision-0))) 2)) (is (= (length (slot-value top-1 'd::used-as-type)) 2))))) @@ -883,43 +902,44 @@ (occ-2 (make-instance 'OccurrenceC)) (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) + (revision-0 0) (revision-1 100) (revision-2 200) (revision-3 300)) (setf *TM-REVISION* revision-1) - (is-false (themes occ-1)) - (is-false (used-as-theme top-1)) + (is-false (themes occ-1 :revision revision-0)) + (is-false (used-as-theme top-1 :revision revision-0)) (add-theme occ-1 top-1) (is (= (length (union (list top-1) - (themes occ-1))) 1)) + (themes occ-1 :revision revision-0))) 1)) (is (= (length (union (list occ-1) - (used-as-theme top-1))) 1)) + (used-as-theme top-1 :revision revision-0))) 1)) (delete-theme occ-1 top-1 :revision revision-2) (is (= (length (union (list top-1) (themes occ-1 :revision revision-1))) 1)) - (is-false (themes occ-1)) - (is-false (used-as-theme top-1)) + (is-false (themes occ-1 :revision revision-0)) + (is-false (used-as-theme top-1 :revision revision-0)) (is-false (themes occ-1 :revision revision-2)) (add-theme occ-1 top-1 :revision revision-3) (is (= (length (union (list top-1) - (themes occ-1))) 1)) + (themes occ-1 :revision revision-0))) 1)) (is (= (length (slot-value occ-1 'd::themes)) 1)) (add-theme occ-1 top-2 :revision revision-2) (is (= (length (union (list top-1 top-2) - (themes occ-1))) 2)) + (themes occ-1 :revision revision-0))) 2)) (is (= (length (union (list top-2) (themes occ-1 :revision revision-2))) 1)) (is (= (length (union (list top-1 top-2) - (themes occ-1))) 2)) + (themes occ-1 :revision revision-0))) 2)) (add-theme occ-2 top-2 :revision revision-3) (is (= (length (union (list top-1 top-2) - (themes occ-1))) 2)) + (themes occ-1 :revision revision-0))) 2)) (is (= (length (union (list top-2) - (themes occ-2))) 1)) + (themes occ-2 :revision revision-0))) 1)) (is (= (length (union (list occ-1) - (used-as-theme top-1))) 1)) + (used-as-theme top-1 :revision revision-0))) 1)) (is (= (length (union (list occ-1 occ-2) - (used-as-theme top-2))) 2)) + (used-as-theme top-2 :revision revision-0))) 2)) (is (= (length (slot-value occ-1 'd::themes)) 2)) (is (= (length (slot-value occ-2 'd::themes)) 1)) (is (= (length (slot-value top-1 'd::used-as-theme)) 1)) @@ -933,67 +953,68 @@ (role-2 (make-instance 'RoleC)) (assoc-1 (make-instance 'AssociationC)) (assoc-2 (make-instance 'AssociationC)) - (revision-1 100) - (revision-2 200) - (revision-3 300) - (revision-4 400)) - (setf *TM-REVISION* revision-1) - (is-false (roles assoc-1)) - (is-false (parent role-1)) + (rev-0 0) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400)) + (setf *TM-REVISION* rev-1) + (is-false (roles assoc-1 :revision rev-0)) + (is-false (parent role-1 :revision rev-0)) (add-parent role-1 assoc-1) (is (= (length (d::versions assoc-1)) 1)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-1) + (and (= (d::start-revision vi) rev-1) (= (d::end-revision vi) 0))) (d::versions assoc-1))) - (is (eql (parent role-1 :revision revision-1) assoc-1)) + (is (eql (parent role-1 :revision rev-1) assoc-1)) (is (= (length (union (list role-1) (roles assoc-1))) 1)) - (add-role assoc-1 role-2 :revision revision-2) + (add-role assoc-1 role-2 :revision rev-2) (is (= (length (d::versions assoc-1)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-2) + (and (= (d::start-revision vi) rev-2) (= (d::end-revision vi) 0))) (d::versions assoc-1))) (is (= (length (union (list role-1 role-2) - (roles assoc-1))) 2)) + (roles assoc-1 :revision rev-0))) 2)) (is (= (length (union (list role-1) - (roles assoc-1 :revision revision-1))) 1)) - (is (eql (parent role-1) assoc-1)) - (is (eql (parent role-2 :revision revision-2) assoc-1)) - (is-false (parent role-2 :revision revision-1)) - (signals error (add-parent role-2 assoc-2 :revision revision-2)) - (delete-role assoc-1 role-1 :revision revision-3) + (roles assoc-1 :revision rev-1))) 1)) + (is (eql (parent role-1 :revision rev-0) assoc-1)) + (is (eql (parent role-2 :revision rev-2) assoc-1)) + (is-false (parent role-2 :revision rev-1)) + (signals error (add-parent role-2 assoc-2 :revision rev-2)) + (delete-role assoc-1 role-1 :revision rev-3) (is (= (length (d::versions assoc-1)) 3)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-3) + (and (= (d::start-revision vi) rev-3) (= (d::end-revision vi) 0))) (d::versions assoc-1))) - (is-false (parent role-1)) + (is-false (parent role-1 :revision rev-0)) (is (= (length (union (list role-2) - (roles assoc-1))) 1)) - (delete-parent role-2 assoc-1 :revision revision-3) - (is-false (parent role-2)) - (is (eql assoc-1 (parent role-2 :revision revision-2))) - (is-false (roles assoc-1)) - (add-role assoc-2 role-1 :revision revision-3) - (add-parent role-2 assoc-2 :revision revision-3) - (is (eql (parent role-2) assoc-2)) + (roles assoc-1 :revision rev-0))) 1)) + (delete-parent role-2 assoc-1 :revision rev-3) + (is-false (parent role-2 :revision rev-0)) + (is (eql assoc-1 (parent role-2 :revision rev-2))) + (is-false (roles assoc-1 :revision rev-0)) + (add-role assoc-2 role-1 :revision rev-3) + (add-parent role-2 assoc-2 :revision rev-3) + (is (eql (parent role-2 :revision rev-0) assoc-2)) (is (= (length (union (list role-1 role-2) (roles assoc-2))) 2)) - (add-role assoc-2 role-1 :revision revision-3) - (add-parent role-2 assoc-2 :revision revision-3) - (is (eql (parent role-2) assoc-2)) + (add-role assoc-2 role-1 :revision rev-3) + (add-parent role-2 assoc-2 :revision rev-3) + (is (eql (parent role-2 :revision rev-0) assoc-2)) (is (= (length (union (list role-1 role-2) - (roles assoc-2))) 2)) + (roles assoc-2 :revision rev-0))) 2)) (is (= (length (slot-value assoc-1 'roles)) 2)) (is (= (length (slot-value assoc-2 'roles)) 2)) (is (= (length (slot-value role-1 'parent)) 2)) (is (= (length (slot-value role-2 'parent)) 2)) - (delete-parent role-1 assoc-2 :revision revision-4) + (delete-parent role-1 assoc-2 :revision rev-4) (is (= (length (d::versions assoc-2)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-4) + (and (= (d::start-revision vi) rev-4) (= (d::end-revision vi) 0))) (d::versions assoc-2)))))) @@ -1005,35 +1026,36 @@ (role-2 (make-instance 'RoleC)) (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) + (revision-0 0) (revision-0-5 50) (revision-1 100) (revision-2 200) (revision-3 300)) (setf *TM-REVISION* revision-1) - (is-false (player role-1)) + (is-false (player role-1 :revision revision-0)) (add-player role-1 top-1) - (is (eql top-1 (player role-1))) + (is (eql top-1 (player role-1 :revision revision-0))) (is-false (player role-1 :revision revision-0-5)) (is (eql top-1 (player role-1 :revision revision-2))) (add-player role-1 top-1) - (is (eql top-1 (player role-1))) + (is (eql top-1 (player role-1 :revision revision-0))) (is-false (player role-1 :revision revision-0-5)) (is (eql top-1 (player role-1 :revision revision-2))) (signals error (add-player role-1 top-2)) (add-player role-2 top-1 :revision revision-2) (is (= (length (union (list role-1 role-2) - (player-in-roles top-1))) 2)) + (player-in-roles top-1 :revision revision-0))) 2)) (is (= (length (union (list role-1) (player-in-roles top-1 :revision revision-1))) 1)) (delete-player role-1 top-1 :revision revision-3) - (is-false (player role-1)) + (is-false (player role-1 :revision revision-0)) (is (= (length (union (list role-2) - (player-in-roles top-1))) 1)) + (player-in-roles top-1 :revision revision-0))) 1)) (add-player role-1 top-1 :revision revision-3) - (is (eql top-1 (player role-1))) + (is (eql top-1 (player role-1 :revision revision-0))) (is (= (length (union (list role-1 role-2) - (player-in-roles top-1))) 2)) + (player-in-roles top-1 :revision revision-0))) 2)) (is (= (length (slot-value top-1 'd::player-in-roles)) 2))))) @@ -1226,6 +1248,7 @@ (reifier-1 (make-instance 'TopicC)) (reifier-2 (make-instance 'TopicC)) (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (revision-0 0) (revision-1 100) (revision-2 200)) (setf *TM-REVISION* revision-1) @@ -1253,7 +1276,7 @@ (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC)) 1)) (is (= (length (union (list ii-1) (item-identifiers rc-2))) 1)) - (is (eql reifier-1 (reifier rc-2))) + (is (eql reifier-1 (reifier rc-2 :revision revision-0))) (delete-construct ii-1) (delete-construct reifier-1) (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))

1 0

[isidorus-cvs] r245 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 22 Mar '10

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 12:24:54 2010 New Revision: 245 Log: new-datamodel: added "add-to-version-history" to all "add-<item>" and "delete-<item>" that are defined for "VersionedConstructC" 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 Mon Mar 22 12:24:54 2010 @@ -171,8 +171,6 @@ ;;TODO: implement merge-construct -> ReifiableConstructC -> ... ;; the method should merge two constructs that are inherited from ;; ReifiableConstructC -;;TODO: implement find-item-by-revision for all classes that don't have their -;; one revision-infos --> PointerC, CharacteristicC, RoleC ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -747,6 +745,16 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric delete-parent (construct parent-construct &key revision) + (:documentation "Sets the assoication-object between the passed + constructs as marded-as-deleted.")) + + +(defgeneric add-parent (construct parent-construct &key revision) + (:documentation "Adds the parent-construct (TopicC or NameC) in form of + a corresponding association to the given object.")) + + (defgeneric find-item-by-revision (construct revision &optional parent-construct) (:documentation "Returns the given object if it exists in the passed @@ -1283,6 +1291,7 @@ return ti-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1338,6 +1347,7 @@ return psi-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1394,6 +1404,7 @@ return loc-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1452,6 +1463,7 @@ return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1501,6 +1513,7 @@ return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1773,55 +1786,55 @@ (parent-construct (first valid-associations)))))) -(defgeneric add-parent (construct parent-construct &key revision) - (:documentation "Adds the parent-construct (TopicC or NameC) in form of - a corresponding association to the given object.") - (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC) - &key (revision *TM-REVISION*)) - (let ((already-set-parent (parent construct :revision revision)) - (same-parent-assoc ;should contain a object that was marked as deleted - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct (parent-construct parent-assoc)) - return parent-assoc))) - (when (and already-set-parent - (not (eql already-set-parent parent-construct))) - (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" - construct parent-construct already-set-parent)) - (cond (already-set-parent - (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct - (parent-construct parent-assoc)) - return parent-assoc))) - (add-to-version-history parent-assoc :start-revision revision))) - (same-parent-assoc - (add-to-version-history same-parent-assoc :start-revision revision)) - (t - (let ((association-type (cond ((typep construct 'OccurrenceC) - 'OccurrenceAssociationC) - ((typep construct 'NameC) - 'NameAssociationC) - (t - 'VariantAssociationC)))) - (make-construct association-type - :characteristic construct - :parent-construct parent-construct - :start-revision revision))))) - construct)) +(defmethod add-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (let ((already-set-parent (parent construct :revision revision)) + (same-parent-assoc ;should contain a object that was marked as deleted + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct (parent-construct parent-assoc)) + return parent-assoc))) + (when (and already-set-parent + (not (eql already-set-parent parent-construct))) + (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + construct parent-construct already-set-parent)) + (cond (already-set-parent + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc :start-revision revision)) + (t + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (make-construct association-type + :characteristic construct + :parent-construct parent-construct + :start-revision revision))))) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct) -(defgeneric delete-parent (construct parent-construct &key revision) - (:documentation "Sets the assoication-object between the passed - constructs as marded-as-deleted.") - (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC) - &key (revision (error "From delete-parent(): revision must be set"))) - (let ((assoc-to-delete - (loop for parent-assoc in (slot-p construct 'parent) - when (eql (parent-construct parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct))) +(defmethod delete-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision (error "From delete-parent(): revision must be set"))) + (let ((assoc-to-delete + (loop for parent-assoc in (slot-p construct 'parent) + when (eql (parent-construct parent-assoc) parent-construct) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct)) ;;; OccurrenceC @@ -2037,6 +2050,7 @@ return role-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -2155,6 +2169,7 @@ return parent-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history parent-construct :start-revision revision) construct)) @@ -2337,9 +2352,7 @@ :parent-construct construct :identifier item-identifier :start-revision revision))) - (when (or (typep merged-construct 'TopicC) - (typep merged-construct 'AssociationC) - (typep merged-construct 'TopicMapC)) + (when (typep construct 'VersionedConstructC) (add-to-version-history merged-construct :start-revision revision)) merged-construct)))) @@ -2354,6 +2367,8 @@ return ii-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2391,9 +2406,7 @@ :reifiable-construct construct :reifier-topic merged-reifier-topic :start-revision revision))) - (when (or (typep merged-construct 'TopicC) - (typep merged-construct 'AssociationC) - (typep merged-construct 'TopicMapC)) + (when (typep construct 'VersionedConstructC) (add-to-version-history merged-construct :start-revision revision)) merged-construct))))) @@ -2408,6 +2421,8 @@ return reifier-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2509,7 +2524,7 @@ :theme-topic theme-topic :scopable-construct construct :start-revision revision))) - (when (typep construct 'AssociationC) + (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2524,6 +2539,8 @@ return theme-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2580,7 +2597,7 @@ :type-topic type-topic :typable-construct construct :start-revision revision)))) - (when (typep construct 'AssociationC) + (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2596,6 +2613,8 @@ return type-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) 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 Mon Mar 22 12:24:54 2010 @@ -62,8 +62,6 @@ :test-find-item-by-revision)) -;;TODO: complete all test of the form test-add-<whatever> -;; --> indirect call of add-to-version-history ;;TODO: test make-construct ;;TODO: test merge-constructs @@ -157,10 +155,20 @@ (signals error (make-instance 'ItemIdentifierC)) (is-false (item-identifiers topic-1)) (add-item-identifier topic-1 ii-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (item-identifiers topic-1)) 1)) (is (eql (first (item-identifiers topic-1)) ii-1)) (is (eql (identified-construct ii-1) topic-1)) (add-item-identifier topic-1 ii-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (item-identifiers topic-1 :revision revision-0)) 2)) (is (= (length (item-identifiers topic-1 :revision revision-1)) 1)) (is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1)) @@ -180,6 +188,11 @@ :revision revision-2))) 2)) (delete-item-identifier topic-1 ii-2 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is-false (item-identifiers topic-1 :revision revision-3)) (add-item-identifier topic-1 ii-1 :revision revision-4) (is (= (length (union (list ii-1) @@ -208,10 +221,20 @@ (signals error (make-instance 'PersistentIdC)) (is-false (psis topic-1)) (add-psi topic-1 psi-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (psis topic-1)) 1)) (is (eql (first (psis topic-1)) psi-1)) (is (eql (identified-construct psi-1) topic-1)) (add-psi topic-1 psi-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (psis topic-1 :revision revision-0)) 2)) (is (= (length (psis topic-1 :revision revision-1)) 1)) (is (eql (first (psis topic-1 :revision revision-1)) psi-1)) @@ -229,6 +252,11 @@ (psis topic-1 :revision revision-2))) 2)) (delete-psi topic-1 psi-2 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is-false (psis topic-1 :revision revision-3)) (add-psi topic-1 psi-1 :revision revision-4) (is (= (length (union (list psi-1) @@ -257,10 +285,20 @@ (signals error (make-instance 'SubjectLocatorC)) (is-false (locators topic-1)) (add-locator topic-1 sl-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (locators topic-1)) 1)) (is (eql (first (locators topic-1)) sl-1)) (is (eql (identified-construct sl-1) topic-1)) (add-locator topic-1 sl-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (locators topic-1 :revision revision-0)) 2)) (is (= (length (locators topic-1 :revision revision-1)) 1)) (is (eql (first (locators topic-1 :revision revision-1)) sl-1)) @@ -271,6 +309,11 @@ (locators topic-1 :revision revision-0))) 2)) (delete-locator topic-1 sl-1 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (union (list sl-2) (locators topic-1 :revision revision-0))) 1)) @@ -311,10 +354,20 @@ :xtm-id "xtm-id-1")) (is-false (topic-identifiers topic-1)) (add-topic-identifier topic-1 ti-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (topic-identifiers topic-1)) 1)) (is (eql (first (topic-identifiers topic-1)) ti-1)) (is (eql (identified-construct ti-1) topic-1)) (add-topic-identifier topic-1 ti-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (topic-identifiers topic-1 :revision revision-0)) 2)) (is (= (length (topic-identifiers topic-1 :revision revision-1)) 1)) (is (eql (first (topic-identifiers topic-1 :revision revision-1)) ti-1)) @@ -325,6 +378,11 @@ (topic-identifiers topic-1 :revision revision-0))) 2)) (delete-topic-identifier topic-1 ti-1 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (union (list ti-2) (topic-identifiers topic-1 :revision revision-0))) 1)) @@ -529,16 +587,31 @@ "Tests variuas functions of the ReifialeConstructC." (with-fixture with-empty-db (*db-dir*) (let ((reifier-top (make-instance 'TopicC)) - (reified-rc (make-instance 'd::ReifiableConstructC))) + (reified-rc (make-instance 'd::AssociationC)) + (version-0-5 50) + (version-1 100) + (version-2 200) + (version-3 300)) (is-false (reifier reified-rc)) (is-false (reified-construct reifier-top)) - (add-reifier reified-rc reifier-top :revision 100) + (add-reifier reified-rc reifier-top :revision version-1) + (is (= (length (d::versions reified-rc)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) version-1) + (= (d::end-revision vi) 0))) + (d::versions reified-rc))) (is (eql reifier-top (reifier reified-rc))) (is (eql reified-rc (reified-construct reifier-top))) - (is (eql reifier-top (reifier reified-rc :revision 200))) - (is (eql reified-rc (reified-construct reifier-top :revision 200))) - (is-false (reifier reified-rc :revision 50)) - (is-false (reified-construct reifier-top :revision 50))))) + (is (eql reifier-top (reifier reified-rc :revision version-2))) + (is (eql reified-rc (reified-construct reifier-top :revision version-2))) + (is-false (reifier reified-rc :revision version-0-5)) + (is-false (reified-construct reifier-top :revision version-0-5)) + (delete-reifier reified-rc reifier-top :revision version-3) + (is (= (length (d::versions reified-rc)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) version-3) + (= (d::end-revision vi) 0))) + (d::versions reified-rc)))))) (test test-OccurrenceC () @@ -560,9 +633,19 @@ (is-false (parent occ-1)) (is-false (occurrences top-1)) (add-occurrence top-1 occ-1 :revision revision-1) + (is (= (length (d::versions top-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-1) (occurrences top-1))) 1)) (add-occurrence top-1 occ-2 :revision revision-2) + (is (= (length (d::versions top-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-1 occ-2) (occurrences top-1))) 2)) (is (= (length (union (list occ-1) @@ -570,6 +653,11 @@ (add-occurrence top-1 occ-2 :revision revision-3) (is (= (length (d::slot-p top-1 'd::occurrences)) 2)) (delete-occurrence top-1 occ-1 :revision revision-4) + (is (= (length (d::versions top-1)) 4)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-2) (occurrences top-1 :revision revision-4))) 1)) (is (= (length (union (list occ-2) @@ -594,7 +682,17 @@ (is (eql top-1 (parent occ-2))) (delete-parent occ-2 top-1 :revision revision-6) (add-parent occ-2 top-2 :revision revision-7) + (is (= (length (d::versions top-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-7) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (delete-parent occ-2 top-2 :revision revision-8) + (is (= (length (d::versions top-2)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-8) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (is-false (parent occ-2)) (add-parent occ-2 top-1 :revision revision-8) (is (eql top-1 (parent occ-2)))))) @@ -678,9 +776,19 @@ (is-false (parent name-1)) (is-false (names top-1)) (add-name top-1 name-1 :revision revision-1) + (is (= (length (d::versions top-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-1) (names top-1))) 1)) (add-name top-1 name-2 :revision revision-2) + (is (= (length (d::versions top-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-1 name-2) (names top-1))) 2)) (is (= (length (union (list name-1) @@ -688,6 +796,11 @@ (add-name top-1 name-2 :revision revision-3) (is (= (length (d::slot-p top-1 'd::names)) 2)) (delete-name top-1 name-1 :revision revision-4) + (is (= (length (d::versions top-1)) 4)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-2) (names top-1 :revision revision-4))) 1)) (is (= (length (union (list name-2) @@ -712,7 +825,17 @@ (is (eql top-1 (parent name-2))) (delete-parent name-2 top-1 :revision revision-6) (add-parent name-2 top-2 :revision revision-7) + (is (= (length (d::versions top-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-7) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (delete-parent name-2 top-2 :revision revision-8) + (is (= (length (d::versions top-2)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-8) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (is-false (parent name-2)) (add-parent name-2 top-1 :revision revision-8) (is (eql top-1 (parent name-2)))))) @@ -812,15 +935,26 @@ (assoc-2 (make-instance 'AssociationC)) (revision-1 100) (revision-2 200) - (revision-3 300)) + (revision-3 300) + (revision-4 400)) (setf *TM-REVISION* revision-1) (is-false (roles assoc-1)) (is-false (parent role-1)) (add-parent role-1 assoc-1) + (is (= (length (d::versions assoc-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is (eql (parent role-1 :revision revision-1) assoc-1)) (is (= (length (union (list role-1) (roles assoc-1))) 1)) (add-role assoc-1 role-2 :revision revision-2) + (is (= (length (d::versions assoc-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is (= (length (union (list role-1 role-2) (roles assoc-1))) 2)) (is (= (length (union (list role-1) @@ -830,6 +964,11 @@ (is-false (parent role-2 :revision revision-1)) (signals error (add-parent role-2 assoc-2 :revision revision-2)) (delete-role assoc-1 role-1 :revision revision-3) + (is (= (length (d::versions assoc-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is-false (parent role-1)) (is (= (length (union (list role-2) (roles assoc-1))) 1)) @@ -850,7 +989,13 @@ (is (= (length (slot-value assoc-1 'roles)) 2)) (is (= (length (slot-value assoc-2 'roles)) 2)) (is (= (length (slot-value role-1 'parent)) 2)) - (is (= (length (slot-value role-2 'parent)) 2))))) + (is (= (length (slot-value role-2 'parent)) 2)) + (delete-parent role-1 assoc-2 :revision revision-4) + (is (= (length (d::versions assoc-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions assoc-2)))))) (test test-player ()

1 0

[isidorus-cvs] r244 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 22 Mar '10

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 09:04:20 2010 New Revision: 244 Log: new-datamodel: add "find-item-by-revision" to classes that are non-VersionedConstructC classes but that are related with their parent-constructs via VersionedAssociationCs. added alsome some unit-tests for this generic 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 Mon Mar 22 09:04:20 2010 @@ -156,12 +156,13 @@ - +;;TOOD: replace the key argument (revision 0)/(start-revision 0) +;; by (start-revision *TM-REVISION*) (revision *TM-REVISION*) +;; to be compatible to the macro with-revision ;;TODO: check merge-constructs in add-topic-identifier, -;; add-item-identifier/add-reifier (can merge the parent construct -;; and the parent's parent construct), add-psi, add-locator -;; (--> duplicate-identifier-error) -;;TODO: finalize add-reifier +;; add-item-identifier/add-reifier (can merge the parent constructs +;; and the parent's parent construct + the reifier constructs), +;; add-psi, add-locator (--> duplicate-identifier-error) ;;TODO: implement a macro "with-merge-construct" that merges constructs ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done @@ -171,7 +172,7 @@ ;; the method should merge two constructs that are inherited from ;; ReifiableConstructC ;;TODO: implement find-item-by-revision for all classes that don't have their -;; one revision-infos +;; one revision-infos --> PointerC, CharacteristicC, RoleC ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -746,6 +747,16 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric find-item-by-revision (construct revision + &optional parent-construct) + (:documentation "Returns the given object if it exists in the passed + version otherwise nil. + Constructs that exist to be owned by parent-constructs + must provide their parent-construct to get the corresponding + revision of the relationship between the construct itself and + its parent-construct.")) + + (defgeneric check-for-duplicate-identifiers (construct) (:documentation "Check for possibly duplicate identifiers and signal an duplicate-identifier-error is such duplicates are found")) @@ -817,6 +828,21 @@ (delete-construct version-info))) +(defmethod find-item-by-revision ((construct VersionedConstructC) + (revision integer) &optional parent-construct) + (declare (ignorable parent-construct)) + (cond ((= revision 0) + (find-most-recent-revision construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions construct)) + construct)))) + + (defmethod get-most-recent-version-info ((construct VersionedConstructC)) (let ((result (find 0 (versions construct) :key #'end-revision))) (if result @@ -836,22 +862,6 @@ construct))) -(defgeneric find-item-by-revision (construct revision) - (:documentation "Returns the given object if it exists in the passed - version otherwise nil.") - (:method ((construct VersionedConstructC) (revision integer)) - (cond ((= revision 0) - (find-most-recent-revision construct)) - (t - (when (find-if - #'(lambda(vi) - (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) - (versions construct)) - construct))))) - - (defgeneric add-to-version-history (construct &key start-revision end-revision) (:documentation "Adds version history to a versioned construct") (:method ((construct VersionedConstructC) @@ -951,6 +961,33 @@ (string= (uri construct) uri)) +(defmethod find-item-by-revision ((construct PointerC) + (revision integer) &optional parent-construct) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'identified-construct))))) + (when assocs + (first assocs))))) + (cond ((= revision 0) + (find-most-recent-revision parent-assoc)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct)))) + nil)) + + (defmethod delete-construct :before ((construct PointerC)) (dolist (p-assoc (slot-p construct 'identified-construct)) (delete-construct p-assoc))) @@ -1685,6 +1722,35 @@ :start-revision start-revision))) +(defmethod find-item-by-revision ((construct CharacteristicC) + (revision integer) &optional parent-construct) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'parent))))) + (when assocs + (first assocs))))) + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct)))) + nil)) + + (defmethod delete-construct :before ((construct CharacteristicC)) (dolist (characteristic-assoc-to-delete (slot-p construct 'parent)) (delete-construct characteristic-assoc-to-delete))) @@ -1997,6 +2063,33 @@ (eql player (player construct :revision start-revision)))) +(defmethod find-item-by-revision ((construct RoleC) + (revision integer) &optional parent-construct) + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'parent))))) + (when assocs + (first assocs))))) + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) + + (defmethod delete-construct :before ((construct RoleC)) (dolist (role-assoc-to-delete (slot-p construct 'parent)) (delete-construct role-assoc-to-delete)) 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 Mon Mar 22 09:04:20 2010 @@ -58,9 +58,12 @@ :test-equivalent-AssociationC :test-equivalent-TopicC :test-equivalent-TopicMapC - :test-class-p)) + :test-class-p + :test-find-item-by-revision)) +;;TODO: complete all test of the form test-add-<whatever> +;; --> indirect call of add-to-version-history ;;TODO: test make-construct ;;TODO: test merge-constructs @@ -1627,6 +1630,80 @@ (is-false (d:PointerC-p class)))))) +(test test-find-item-by-revision () + "Tests the function find-item-by-revision." + (with-fixture with-empty-db (*db-dir*) + (let ((top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (psi-1 (make-instance 'PersistentIdC :uri "psi-1")) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (variant-1 (make-instance 'VariantC)) + (role-1 (make-instance 'RoleC)) + (rev-0 0) + (rev-0-5 50) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (rev-5 500)) + (setf *TM-REVISION* rev-1) + (d::add-to-version-history top-1 :start-revision rev-1) + (d::add-to-version-history top-1 :start-revision rev-3) + (is (eql top-1 (find-item-by-revision top-1 rev-1))) + (is (eql top-1 (find-item-by-revision top-1 rev-0))) + (is (eql top-1 (find-item-by-revision top-1 rev-4))) + (is (eql top-1 (find-item-by-revision top-1 rev-2))) + (is-false (find-item-by-revision top-1 rev-0-5)) + (add-item-identifier top-1 ii-1 :revision rev-3) + (add-item-identifier top-1 ii-2 :revision rev-3) + (add-item-identifier top-1 ii-1 :revision rev-4) + (delete-item-identifier top-1 ii-1 :revision rev-5) + (add-item-identifier top-2 ii-1 :revision rev-5) + (add-psi top-2 psi-1 :revision rev-1) + (is (eql ii-1 (find-item-by-revision ii-1 rev-3 top-1))) + (is (eql ii-1 (find-item-by-revision ii-1 rev-4 top-1))) + (is-false (find-item-by-revision ii-1 rev-2 top-1)) + (is-false (find-item-by-revision ii-1 rev-5 top-1)) + (is-false (find-item-by-revision ii-1 rev-3)) + (is-false (find-item-by-revision ii-1 rev-0 top-1)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-5 top-2))) + (add-role assoc-1 role-1 :revision rev-1) + (delete-role assoc-1 role-1 :revision rev-3) + (add-role assoc-2 role-1 :revision rev-5) + (is (eql role-1 (find-item-by-revision role-1 rev-1 assoc-1))) + (is (eql role-1 (find-item-by-revision role-1 rev-2 assoc-1))) + (is (eql role-1 (find-item-by-revision role-1 rev-5 assoc-2))) + (is (eql role-1 (find-item-by-revision role-1 rev-0 assoc-2))) + (is-false (find-item-by-revision role-1 rev-0-5 assoc-1)) + (is-false (find-item-by-revision role-1 rev-0 assoc-1)) + (is-false (find-item-by-revision role-1 rev-3 assoc-1)) + (is-false (find-item-by-revision role-1 rev-3 assoc-2)) + (add-name top-1 name-1 :revision rev-1) + (delete-name top-1 name-1 :revision rev-3) + (add-name top-2 name-1 :revision rev-3) + (is (eql name-1 (find-item-by-revision name-1 rev-1 top-1))) + (is (eql name-1 (find-item-by-revision name-1 rev-2 top-1))) + (is (eql name-1 (find-item-by-revision name-1 rev-5 top-2))) + (is (eql name-1 (find-item-by-revision name-1 rev-0 top-2))) + (is-false (find-item-by-revision name-1 rev-0-5 top-1)) + (is-false (find-item-by-revision name-1 rev-0 top-1)) + (is-false (find-item-by-revision name-1 rev-3 top-1)) + (add-variant name-1 variant-1 :revision rev-1) + (delete-variant name-1 variant-1 :revision rev-3) + (add-variant name-2 variant-1 :revision rev-3) + (is (eql variant-1 (find-item-by-revision variant-1 rev-1 name-1))) + (is (eql variant-1 (find-item-by-revision variant-1 rev-2 name-1))) + (is (eql variant-1 (find-item-by-revision variant-1 rev-5 name-2))) + (is (eql variant-1 (find-item-by-revision variant-1 rev-0 name-2))) + (is-false (find-item-by-revision variant-1 rev-0-5 name-1)) + (is-false (find-item-by-revision variant-1 rev-0 name-1)) + (is-false (find-item-by-revision variant-1 rev-3 name-1))))) + @@ -1672,4 +1749,5 @@ (it.bese.fiveam:run! 'test-equivalent-TopicC) (it.bese.fiveam:run! 'test-equivalent-TopicMapC) (it.bese.fiveam:run! 'test-class-p) + (it.bese.fiveam:run! 'test-find-item-by-revision) ) \ No newline at end of file

1 0

[isidorus-cvs] r243 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 22 Mar '10

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 07:54:27 2010 New Revision: 243 Log: new-datamodel: added "make-construct" for VersionedAssocitionC and unknown classes via "(apply make-instance class-symbol args)" replaced all "make-instance" and "add-to-version-history" calls by "make-construct" in all add-<whatever> generics 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 Mon Mar 22 07:54:27 2010 @@ -146,6 +146,7 @@ :changed-p :check-for-duplicate-identifiers :find-item-by-content + :rec-remf ;;globals :*TM-REVISION* @@ -161,8 +162,6 @@ ;; and the parent's parent construct), add-psi, add-locator ;; (--> duplicate-identifier-error) ;;TODO: finalize add-reifier -;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo -;; initarg in make-construct ;;TODO: implement a macro "with-merge-construct" that merges constructs ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done @@ -623,6 +622,15 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun rec-remf (plist keyword) + "Calls remf for the past plist with the given keyword until + all key-value-pairs corresponding to the passed keyword were removed." + (declare (list plist) (keyword keyword)) + (loop while (getf plist keyword) + do (remf plist keyword)) + plist) + + (defun get-item-by-content (content &key (revision *TM-REVISION*)) "Finds characteristics by their (atomic) content." (flet @@ -1220,10 +1228,10 @@ return ti-assoc))) (add-to-version-history ti-assoc :start-revision revision))) (t - (let ((assoc (make-instance 'TopicIdAssociationC - :parent-construct construct - :identifier topic-identifier))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'TopicIdAssociationC + :parent-construct construct + :identifier topic-identifier + :start-revision revision))) (add-to-version-history merged-construct :start-revision revision) merged-construct)))) @@ -1275,10 +1283,10 @@ return psi-assoc))) (add-to-version-history psi-assoc :start-revision revision))) (t - (let ((assoc (make-instance 'PersistentIdAssociationC - :parent-construct construct - :identifier psi))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'PersistentIdAssociationC + :parent-construct construct + :identifier psi + :start-revision revision))) (add-to-version-history merged-construct :start-revision revision) merged-construct)))) @@ -1331,11 +1339,10 @@ return loc-assoc))) (add-to-version-history loc-assoc :start-revision revision))) (t - (let ((assoc - (make-instance 'SubjectLocatorAssociationC - :parent-construct construct - :identifier locator))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'SubjectLocatorAssociationC + :parent-construct construct + :identifier locator + :start-revision revision))) (add-to-version-history merged-construct :start-revision revision) merged-construct)))) @@ -1390,11 +1397,10 @@ construct) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) - (let ((assoc - (make-instance 'NameAssociationC - :parent-construct construct - :characteristic name))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'NameAssociationC + :parent-construct construct + :characteristic name + :start-revision revision))) (add-to-version-history construct :start-revision revision) construct)) @@ -1440,11 +1446,10 @@ when (eql (parent-construct occ-assoc) construct) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) - (let ((assoc - (make-instance 'OccurrenceAssociationC - :parent-construct construct - :characteristic occurrence))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'OccurrenceAssociationC + :parent-construct construct + :characteristic occurrence + :start-revision revision))) (add-to-version-history construct :start-revision revision) construct)) @@ -1732,10 +1737,10 @@ 'NameAssociationC) (t 'VariantAssociationC)))) - (let ((assoc (make-instance association-type - :characteristic construct - :parent-construct parent-construct))) - (add-to-version-history assoc :start-revision revision)))))) + (make-construct association-type + :characteristic construct + :parent-construct parent-construct + :start-revision revision))))) construct)) @@ -1864,11 +1869,10 @@ when (eql (characteristic variant-assoc) variant) return variant-assoc))) (add-to-version-history variant-assoc :start-revision revision)) - (let ((assoc - (make-instance 'VariantAssociationC - :characteristic variant - :parent-construct construct))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'VariantAssociationC + :characteristic variant + :parent-construct construct + :start-revision revision))) construct)) @@ -1949,11 +1953,10 @@ when (eql (role role-assoc) role) return role-assoc))) (add-to-version-history role-assoc :start-revision revision)) - (let ((assoc - (make-instance 'RoleAssociationC - :role role - :parent-construct construct))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'RoleAssociationC + :role role + :parent-construct construct + :start-revision revision))) (add-to-version-history construct :start-revision revision) construct)) @@ -2043,10 +2046,10 @@ (same-parent-assoc (add-to-version-history same-parent-assoc :start-revision revision)) (t - (let ((assoc (make-instance 'RoleAssociationC - :role construct - :parent-construct parent-construct))) - (add-to-version-history assoc :start-revision revision))))) + (make-construct 'RoleAssociationC + :role construct + :parent-construct parent-construct + :start-revision revision)))) (add-to-version-history parent-construct :start-revision revision) construct) @@ -2095,10 +2098,10 @@ (same-player-assoc (add-to-version-history same-player-assoc :start-revision revision)) (t - (let ((assoc (make-instance 'PlayerAssociationC - :parent-construct construct - :player-topic player-topic))) - (add-to-version-history assoc :start-revision revision))))) + (make-construct 'PlayerAssociationC + :parent-construct construct + :player-topic player-topic + :start-revision revision)))) construct)) @@ -2237,10 +2240,10 @@ return ii-assoc))) (add-to-version-history ii-assoc :start-revision revision))) (t - (let ((assoc (make-instance 'ItemIdAssociationC - :parent-construct construct - :identifier item-identifier))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'ItemIdAssociationC + :parent-construct construct + :identifier item-identifier + :start-revision revision))) (when (or (typep merged-construct 'TopicC) (typep merged-construct 'AssociationC) (typep merged-construct 'TopicMapC)) @@ -2291,10 +2294,10 @@ (all-constructs (merge-constructs (first all-constructs) construct)) (t - (let ((assoc (make-instance 'ReifierAssociationC - :reifiable-construct construct - :reifier-topic merged-reifier-topic))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'ReifierAssociationC + :reifiable-construct construct + :reifier-topic merged-reifier-topic + :start-revision revision))) (when (or (typep merged-construct 'TopicC) (typep merged-construct 'AssociationC) (typep merged-construct 'TopicMapC)) @@ -2409,11 +2412,10 @@ when (eql (theme-topic theme-assoc) theme-topic) return theme-assoc))) (add-to-version-history theme-assoc :start-revision revision)) - (let ((assoc - (make-instance 'ScopeAssociationC - :theme-topic theme-topic - :scopable-construct construct))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'ScopeAssociationC + :theme-topic theme-topic + :scopable-construct construct + :start-revision revision))) (when (typep construct 'AssociationC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2481,11 +2483,10 @@ (same-type-assoc (add-to-version-history same-type-assoc :start-revision revision)) (t - (let ((assoc - (make-instance 'TypeAssociationC - :type-topic type-topic - :typable-construct construct))) - (add-to-version-history assoc :start-revision revision))))) + (make-construct 'TypeAssociationC + :type-topic type-topic + :typable-construct construct + :start-revision revision)))) (when (typep construct 'AssociationC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2582,6 +2583,8 @@ (apply #'make-role args)) ((AssociationC-p class-symbol) (apply #'make-association args)) + ((VersionedConstructC-p class-symbol) + (apply #'make-instance (rec-remf args :start-revision))) (t (apply #'make-instance class-symbol args)))) (start-revision (getf args :start-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 Mon Mar 22 07:54:27 2010 @@ -908,7 +908,6 @@ (topics tm-1))) 1)) (is (= (length (union (list tm-1) (in-topicmaps top-1))) 1)) - (is-false (topics tm-1 :revision revision-0-5)) (is-false (in-topicmaps top-1 :revision revision-0-5)) (d::add-to-version-history assoc-1 :start-revision revision-1) (add-to-tm tm-1 assoc-1) @@ -916,14 +915,12 @@ (associations tm-1))) 1)) (is (= (length (union (list tm-1) (in-topicmaps assoc-1))) 1)) - (is-false (associations tm-1 :revision revision-0-5)) (is-false (in-topicmaps assoc-1 :revision revision-0-5)) (add-to-tm tm-2 top-1) (is (= (length (union (list top-1) (topics tm-2))) 1)) (is (= (length (union (list tm-2 tm-1) (in-topicmaps top-1))) 2)) - (is-false (topics tm-2 :revision revision-0-5)) (is-false (in-topicmaps top-1 :revision revision-0-5)) (d::add-to-version-history assoc-1 :start-revision revision-1) (add-to-tm tm-2 assoc-1) @@ -931,7 +928,6 @@ (associations tm-2))) 1)) (is (= (length (union (list tm-2 tm-1) (in-topicmaps assoc-1))) 2)) - (is-false (associations tm-2 :revision revision-0-5)) (is-false (in-topicmaps assoc-1 :revision revision-0-5)))))

1 0

[isidorus-cvs] r242 - in branches/new-datamodel/src: json xml/xtm
by Lukas Giessmann 21 Mar '10

21 Mar '10

Author: lgiessmann Date: Sun Mar 21 15:25:42 2010 New Revision: 242 Log: new-datamodel: changed some code sections that caused problems with the package "json" --> the compilation of isidorus succeeds now without errors and warnings but most likely there currently exist some semantic errors Modified: branches/new-datamodel/src/json/json_importer.lisp branches/new-datamodel/src/xml/xtm/importer.lisp Modified: branches/new-datamodel/src/json/json_importer.lisp ============================================================================== --- branches/new-datamodel/src/json/json_importer.lisp (original) +++ branches/new-datamodel/src/json/json_importer.lisp Sun Mar 21 15:25:42 2010 @@ -68,7 +68,7 @@ (declare (integer start-revision)) (declare (TopicMapC tm)) (setf roles (xml-importer::set-standard-role-types roles)) - (add-to-topicmap tm + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision :item-identifiers item-identifiers @@ -127,7 +127,7 @@ do (json-to-occurrence occurrence-values top start-revision)) (dolist (instanceOf-top instanceof-topics) (json-create-instanceOf-association instanceOf-top top start-revision :tm tm)) -; (add-to-topicmap tm top) ; will be done in "json-to-stub" +; (add-to-tm tm top) ; will be done in "json-to-stub" top))))) @@ -157,7 +157,7 @@ :psis subject-identifiers :topicid (getf json-decoded-list :id) :xtm-id xtm-id))) - (add-to-topicmap tm top) + (add-to-tm tm top) top))))) @@ -329,7 +329,7 @@ (unless (and associationtype roletype1 roletype2) (error "Error in the creation of an instanceof association: core topics are missing")) - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC Modified: branches/new-datamodel/src/xml/xtm/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer.lisp Sun Mar 21 15:25:42 2010 @@ -136,7 +136,7 @@ (let ((top (from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm"))) - (add-to-topicmap tm top))))))) + (add-to-tm tm top))))))) ;TODO: replace the two importers with this macro (defmacro importer-mac @@ -190,7 +190,7 @@ (make-condition 'missing-reference-error :message "could not find type topic (first player)" :reference topicid-of-supertype))) - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC

1 0

[isidorus-cvs] r241 - in branches/new-datamodel/src: model xml/rdf
by Lukas Giessmann 21 Mar '10

21 Mar '10

Author: lgiessmann Date: Sun Mar 21 15:17:59 2010 New Revision: 241 Log: new-datamodel: changed some code sections that caused problems with the package "xml" Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/xml/rdf/importer.lisp branches/new-datamodel/src/xml/rdf/map_to_tm.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 21 15:17:59 2010 @@ -22,6 +22,8 @@ :TopicMapConstructC :VersionedConstructC :ReifiableConstructC + :ScopableC + :TypableC :TopicMapC :AssociationC :RoleC Modified: branches/new-datamodel/src/xml/rdf/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/importer.lisp (original) +++ branches/new-datamodel/src/xml/rdf/importer.lisp Sun Mar 21 15:17:59 2010 @@ -67,7 +67,7 @@ ((top (from-topic-elem-to-stub top-elem revision :xtm-id *rdf-core-xtm*))) - (add-to-topicmap xml-importer::tm top)))))))) + (add-to-tm xml-importer::tm top)))))))) (defun import-dom (rdf-dom start-revision @@ -355,7 +355,7 @@ (list :instance-of role-type-2 :player sub-top)))) (let ((assoc - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -396,7 +396,7 @@ (list :instance-of roletype-2 :player instance-top)))) (let ((assoc - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -449,7 +449,7 @@ :uri ii-uri :start-revision start-revision))))) (handler-case (let ((top - (add-to-topicmap + (add-to-tm tm (make-construct 'TopicC @@ -502,7 +502,7 @@ (list :instance-of role-type-2 :player top)))) (let ((assoc - (add-to-topicmap tm (make-construct 'AssociationC + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision :instance-of type-top :roles roles)))) @@ -531,7 +531,7 @@ (list :instance-of role-type-2 :player object-topic)))) (let ((assoc - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision :instance-of associationtype-topic Modified: branches/new-datamodel/src/xml/rdf/map_to_tm.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/map_to_tm.lisp (original) +++ branches/new-datamodel/src/xml/rdf/map_to_tm.lisp Sun Mar 21 15:17:59 2010 @@ -188,7 +188,7 @@ (delete-related-associations assoc-top) (d::delete-construct assoc-top) (with-tm (start-revision document-id tm-id) - (add-to-topicmap + (add-to-tm xml-importer::tm (let ((association (make-construct 'AssociationC @@ -229,9 +229,9 @@ (new-item-ids (map-isi-identifiers top start-revision)) (occurrence-topics (get-isi-occurrences top start-revision)) (name-topics (get-isi-names top start-revision))) - (bound-subject-identifiers top new-psis) - (bound-subject-locators top new-locators) - (bound-item-identifiers top new-item-ids) + (bound-subject-identifiers top new-psis start-revision) + (bound-subject-locators top new-locators start-revision) + (bound-item-identifiers top new-item-ids start-revision) (map 'list #'(lambda(occurrence-topic) (map-isi-occurrence top occurrence-topic start-revision)) occurrence-topics) @@ -560,7 +560,7 @@ ids))))) -(defun bound-item-identifiers (construct identifiers) +(defun bound-item-identifiers (construct identifiers start-revision) "Bounds the passed item-identifier to the passed construct." (declare (ReifiableConstructC construct)) (dolist (id identifiers) @@ -569,11 +569,12 @@ (string= (uri ii) (uri id))) (item-identifiers construct)) (d::delete-construct id) - (setf (identified-construct id) construct))) + (add-item-identifier (identified-construct id :revision start-revision) + construct :revision start-revision))) construct) -(defun bound-subject-identifiers (top identifiers) +(defun bound-subject-identifiers (top identifiers start-revision) "Bounds the passed psis to the passed topic." (declare (TopicC top)) (dolist (id identifiers) @@ -582,11 +583,12 @@ (string= (uri psi) (uri id))) (psis top)) (d::delete-construct id) - (setf (identified-construct id) top))) + (add-psi (identified-construct id :revision start-revision) + top :revision start-revision))) top) -(defun bound-subject-locators (top locators) +(defun bound-subject-locators (top locators start-revision) "Bounds the passed locators to the passed topic." (declare (TopicC top)) (dolist (id locators) @@ -595,7 +597,8 @@ (string= (uri locator) (uri id))) (locators top)) (d::delete-construct id) - (setf (identified-construct id) top))) + (add-locator (identified-construct id :revision start-revision) + top :revision start-revision))) top)

1 0

[isidorus-cvs] r240 - in branches/new-datamodel/src: model rest_interface xml/rdf xml/xtm
by Lukas Giessmann 21 Mar '10

21 Mar '10

Author: lgiessmann Date: Sun Mar 21 14:15:47 2010 New Revision: 240 Log: new-datamodel: changed some code sections that caused problems with "rdf_exporter.lisp" Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/rest_interface/read.lisp branches/new-datamodel/src/xml/rdf/exporter.lisp branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 21 14:15:47 2010 @@ -20,12 +20,17 @@ *instance-psi*) (:export ;;classes :TopicMapConstructC + :VersionedConstructC + :ReifiableConstructC :TopicMapC :AssociationC :RoleC + :CharacteristicC :OccurrenceC :NameC :VariantC + :PointerC + :IdentifierC :PersistentIdC :ItemIdentifierC :SubjectLocatorC @@ -124,6 +129,7 @@ :VersionedConstructC-p :make-construct :list-instanceOf + :list-super-types :in-topicmap :string-starts-with :get-fragments @@ -131,6 +137,7 @@ :get-all-revisions :unique-id :topic + :referenced-topics :revision :get-all-revisions-for-tm :add-source-locator @@ -1591,28 +1598,56 @@ :error-if-nil error-if-nil)) - -(defgeneric list-instanceOf (topic &key tm) +(defgeneric list-instanceOf (topic &key tm revision) (:documentation "Generates a list of all topics that this topic is an - instance of, optionally filtered by a topic map")) - - -(defmethod list-instanceOf ((topic TopicC) &key (tm nil)) - (remove-if - #'null - (map 'list #'(lambda(x) - (when (loop for psi in (psis (instance-of x)) - when (string= (uri psi) constants:*instance-psi*) - return t) - (loop for role in (roles (parent x)) - when (not (eq role x)) - return (player role)))) - (if tm - (remove-if-not - (lambda (role) - (in-topicmap tm (parent role))) - (player-in-roles topic)) - (player-in-roles topic))))) + instance of, optionally filtered by a topic map") + (:method ((topic TopicC) &key (tm nil) (revision 0)) + (declare (type (or null TopicMapC) tm) + (integer revision)) + (remove-if + #'null + (map 'list + #'(lambda(x) + (when (loop for psi in (psis (instance-of x :revision revision) + :revision revision) + when (string= (uri psi) constants:*instance-psi*) + return t) + (loop for role in (roles (parent x :revision revision) + :revision revision) + when (not (eq role x)) + return (player role :revision revision)))) + (if tm + (remove-if-not + (lambda (role) + (in-topicmap tm (parent role :revision revision))) + (player-in-roles topic :revision revision)) + (player-in-roles topic :revision revision)))))) + + +(defgeneric list-super-types (topic &key tm revision) + (:documentation "Generate a list of all topics that this topic is an + subclass of, optionally filtered by a topic map") + (:method ((topic TopicC) &key (tm nil) (revision 0)) + (declare (type (or null TopicMapC) tm) + (integer revision)) + (remove-if + #'null + (map 'list + #'(lambda(x) + (when (loop for psi in (psis (instance-of x :revision revision) + :revision revision) + when (string= (uri psi) *subtype-psi*) + return t) + (loop for role in (roles (parent x :revision revision) + :revision revision) + when (not (eq role x)) + return (player role :revision revision)))) + (if tm + (remove-if-not + (lambda (role) + (in-topicmap tm (parent role :revision revision))) + (player-in-roles topic :revision revision)) + (player-in-roles topic :revision revision)))))) ;;; CharacteristicC Modified: branches/new-datamodel/src/rest_interface/read.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/read.lisp (original) +++ branches/new-datamodel/src/rest_interface/read.lisp Sun Mar 21 14:15:47 2010 @@ -67,7 +67,7 @@ (source-locator (source-locator-prefix feed))) ;check if xtm-id has already been imported or if the entry is older ;than the snapshot feed. If so, don't do it again - (unless (or (xtm-id-p xtm-id) (string> (atom:updated entry) (atom:updated imported-snapshot-entry))) + (unless (or (string> (atom:updated entry) (atom:updated imported-snapshot-entry))) (when top (mark-as-deleted top :source-locator source-locator :revision revision)) ;(format t "Fragment feed: ~a~&" (link entry)) @@ -98,10 +98,11 @@ (find most-recent-update entry-list :key #'updated :test #'string=))) (defun most-recent-imported-snapshot (all-snapshot-entries) - (let - ((all-imported-entries - (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id))) - (most-recent-entry all-imported-entries))) +; (let +; ((all-imported-entries +; (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id))) +; (most-recent-entry all-imported-entries)) + (most-recent-entry all-snapshot-entries)) (defun import-snapshots-feed (snapshot-feed-url &key tm-id) "checks if we already imported any of this feed's snapshots. If not, Modified: branches/new-datamodel/src/xml/rdf/exporter.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/exporter.lisp (original) +++ branches/new-datamodel/src/xml/rdf/exporter.lisp Sun Mar 21 14:15:47 2010 @@ -216,7 +216,7 @@ (declare (TopicC topic)) (if (psis topic) (cxml:attribute "rdf:resource" - (if (reified topic) + (if (reified-construct topic) (let ((psi (get-reifier-psi topic))) (if psi (concatenate 'string "#" (get-reifier-uri topic)) @@ -592,7 +592,7 @@ (t-occs (occurrences construct)) (t-assocs (list-rdf-mapped-associations construct))) (if psi - (if (reified construct) + (if (reified-construct construct) (let ((reifier-uri (get-reifier-uri construct))) (if reifier-uri (cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct))) @@ -627,7 +627,7 @@ (ii (item-identifiers construct)) (sl (locators construct))) (if psi - (if (reified construct) + (if (reified-construct construct) (let ((reifier-uri (get-reifier-uri construct))) (if reifier-uri (cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct))) Modified: branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp Sun Mar 21 14:15:47 2010 @@ -83,7 +83,7 @@ ((typep parent-construct 'NameC) parent-construct) ((typep parent-construct 'VariantC) - (name parent-construct)) + (parent parent-construct)) (t (error "from-variant-elem-xtm1.0: parent-construct is neither NameC nor VariantC")))) (reifier-topic (get-reifier-topic-xtm1.0 variant-elem))) @@ -394,7 +394,7 @@ (dolist (instanceOf-topicRef instanceOf-topicRefs) (create-instanceof-association instanceOf-topicRef top start-revision :xtm-id xtm-id :tm tm)) - (add-to-topicmap tm top)))) + (add-to-tm tm top)))) (defun from-association-elem-xtm1.0 (assoc-elem start-revision &key tm (xtm-id *current-xtm*)) @@ -420,7 +420,7 @@ (unless type (format t "from-association-elem-xtm1.0: type is missing -> http://www.topicmaps.org/xtm/1.0/core.xtm#association~%") (setf type (get-item-by-id "association" :xtm-id "core.xtm"))) - (add-to-topicmap tm + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision :instance-of type Modified: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Sun Mar 21 14:15:47 2010 @@ -313,7 +313,7 @@ (create-instanceof-association topicref top start-revision :tm tm :xtm-id xtm-id)) - (add-to-topicmap tm top) + (add-to-tm tm top) top)))) @@ -386,7 +386,7 @@ *xtm2.0-ns* "role"))) (reifier-topic (get-reifier-topic assoc-elem))) (setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -415,7 +415,7 @@ (let ((topic-vector (get-topic-elems xtm-dom))) (loop for top-elem across topic-vector do - (add-to-topicmap + (add-to-tm tm (from-topic-elem-to-stub top-elem revision :xtm-id xtm-id))))))

1 0

[isidorus-cvs] r239 - branches/new-datamodel/src/model
by Lukas Giessmann 21 Mar '10

21 Mar '10

Author: lgiessmann Date: Sun Mar 21 13:26:05 2010 New Revision: 239 Log: new-datamodel: optimized "make-construct" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 21 13:26:05 2010 @@ -2534,17 +2534,19 @@ (let ((construct (cond ((PointerC-p class-symbol) - (make-pointer class-symbol (getf args :uri) args)) + (apply #'make-pointer class-symbol args)) ((CharacteristicC-p class-symbol) - (make-characteristic class-symbol args)) + (apply #'make-characteristic class-symbol args)) ((TopicC-p class-symbol) - (make-topic args)) + (apply #'make-topic args)) ((TopicMapC-p class-symbol) - (make-tm args)) + (apply #'make-tm args)) ((RoleC-p class-symbol) - (make-role args)) + (apply #'make-role args)) ((AssociationC-p class-symbol) - (make-association args)))) + (apply #'make-association args)) + (t + (apply #'make-instance class-symbol args)))) (start-revision (getf args :start-revision))) (when (typep construct 'TypableC) (complete-typable construct (getf args :instance-of) @@ -2552,6 +2554,10 @@ (when (typep construct 'ScopableC) (complete-scopable construct (getf args :themes) :start-revision start-revision)) + (when (typep construct 'VersionedConstructC) + (unless start-revision + (error "From make-construct(): start-revision must be set")) + (add-to-version-history construct :start-revision start-revision)) (if (typep construct 'ReifiableConstructC) (complete-reifiable construct (getf args :item-identtifiers) (getf args :reifier) :start-revision start-revision) @@ -2562,14 +2568,13 @@ "Returns an association object. If the association has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" - (let ((instance-of (getf (first args) :instance-of)) - (start-revision (getf (first args) :start-revision)) - (themes (get (first args) :themes)) - (roles (get (first args) :roles)) - (err "From make-association(): ")) - (unless start-revision (error "~astart-revision must be set" err)) - (unless roles (error "~aroles must be set" err)) - (unless instance-of (error "~ainstance-of must be set" err)) + (let ((instance-of (getf args :instance-of)) + (start-revision (getf args :start-revision)) + (themes (get args :themes)) + (roles (get args :roles))) + (when (and (or roles instance-of themes) + (not start-revision)) + (error "From make-association(): start-revision must be set")) (let ((association (let ((existing-association (remove-if @@ -2597,11 +2602,10 @@ (let ((parent (getf args :parent)) (instance-of (getf args :instance-of)) (player (getf args :player)) - (start-revision (getf args :start-revision)) - (err "From make-role(): ")) - (unless start-revision (error "~astart-revision must be set" err)) - (unless instance-of (error "~ainstance-of must be set" err)) - (unless player (error "~aplayer must be set" err)) + (start-revision (getf args :start-revision))) + (when (and (or instance-of player parent) + (not start-revision)) + (error "From make-role(): start-revision must be set")) (let ((role (let ((existing-role (remove-if @@ -2631,10 +2635,10 @@ (reifier (getf args :reifier)) (topics (getf args :topics)) (assocs (getf args :associations)) - (start-revision (getf args :start-revision)) - (err "From make-tm(): ")) - (unless item-identifiers (error "~aitem-identifiers must be set" err)) - (unless start-revision (error "~astart-revision must be set" err)) + (start-revision (getf args :start-revision))) + (when (and (or item-identifiers reifier) + (not start-revision)) + (error "From make-tm(): start-revision must be set")) (let ((tm (let ((existing-tms (remove-if @@ -2667,10 +2671,11 @@ (item-identifiers (getf args :item-identifiers)) (topic-identifiers (getf args :topic-identifiers)) (names (getf args :names)) - (occurrences (getf args :occurrences)) - (err "From make-topic(): ")) - (unless topic-identifiers (error "~atopic-identifiers must be set" err)) - (unless start-revision (error "~astart-revision must be set" err)) + (occurrences (getf args :occurrences))) + (when (and (or psis locators item-identifiers topic-identifiers + names occurrences) + (not start-revision)) + (error "From make-topic(): start-revision must be set")) (let ((topic (let ((existing-topics (remove-if @@ -2711,19 +2716,16 @@ To check if there is existing an equivalent construct the parameter parent-construct must be set. This function only exists for being used by make-construct!" - (let ((charvalue (getf (first args) :charvalue)) - (start-revision (getf (first args) :start-revision)) - (datatype (getf (first args) :datatype)) - (instance-of (getf (first args) :instance-of)) - (themes (getf (first args) :themes)) - (variants (getf (first args) :variants)) - (parent (getf (first args) :parent)) - (err "From make-characteristic(): ")) - (unless start-revision (error "~astart-revision must be set" err)) - (unless charvalue (error "~acharvalue must be set" err)) - (when (and (or (OccurrenceC-p class-symbol) (NameC-p class-symbol)) - (not instance-of)) - (error "~ainstance-of must be set" err)) + (let ((charvalue (getf args :charvalue)) + (start-revision (getf args :start-revision)) + (datatype (getf args :datatype)) + (instance-of (getf args :instance-of)) + (themes (getf args :themes)) + (variants (getf args :variants)) + (parent (getf args :parent))) + (when (and (or instance-of themes variants parent) + (not start-revision)) + (error "From make-characteristic(): start-revision must be set")) (let ((characteristic (let ((existing-characteristic (when parent @@ -2752,13 +2754,12 @@ "Returns a pointer object with the specified parameters. If an equivalen construct has already existed this one is returned. This function only exists for beoing used by make-construct!" - (let ((uri (getf (first args) :uri)) - (xtm-id (getf (first args) :xtm-id)) - (start-revision (getf (first args) :start-revision)) - (identified-construct (getf (first args) :identified-construct)) - (err "From make-pointer(): ")) + (let ((uri (getf args :uri)) + (xtm-id (getf args :xtm-id)) + (start-revision (getf args :start-revision)) + (identified-construct (getf args :identified-construct))) (when (and identified-construct (not start-revision)) - (error "~astart-revision must be set" err)) + (error "From make-pointer(): start-revision must be set")) (let ((identifier (let ((existing-pointer (remove-if

1 0

[isidorus-cvs] r238 - in branches/new-datamodel/src: json model unit_tests xml/xtm
by Lukas Giessmann 21 Mar '10

21 Mar '10

Author: lgiessmann Date: Sun Mar 21 12:53:44 2010 New Revision: 238 Log: new-datamodel: changed some sections that causes errors with other packages Modified: branches/new-datamodel/src/json/json_exporter.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/importer_test.lisp branches/new-datamodel/src/unit_tests/json_test.lisp branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp Modified: branches/new-datamodel/src/json/json_exporter.lisp ============================================================================== --- branches/new-datamodel/src/json/json_exporter.lisp (original) +++ branches/new-datamodel/src/json/json_exporter.lisp Sun Mar 21 12:53:44 2010 @@ -46,7 +46,7 @@ (eql (elt value 0) #\#)) (get-item-by-id (subseq value 1) :xtm-id xtm-id)))) (if ref-topic - (concatenate 'string "#" (topicid ref-topic)) + (concatenate 'string "#" (topic-id ref-topic)) value)))) (json:encode-json-to-string inner-value)) ",\"resourceData\":null") @@ -147,7 +147,7 @@ (defmethod to-json-string ((instance TopicC) &key (xtm-id d:*current-xtm*)) "transforms an TopicC object to a json string" (let ((id - (concatenate 'string "\"id\":" (json:encode-json-to-string (topicid instance)))) + (concatenate 'string "\"id\":" (json:encode-json-to-string (topic-id instance)))) (itemIdentity (concatenate 'string "\"itemIdentities\":" (identifiers-to-json-string instance :what 'item-identifiers))) @@ -188,7 +188,7 @@ subjectIdentifiers" (when topic (let ((id - (concatenate 'string "\"id\":" (json:encode-json-to-string (topicid topic)))) + (concatenate 'string "\"id\":" (json:encode-json-to-string (topic-id topic)))) (itemIdentity (concatenate 'string "\"itemIdentities\":" (identifiers-to-json-string topic :what 'item-identifiers))) @@ -310,7 +310,7 @@ *occurrences (jonly the resourceRef and resourceData elements)" (declare (TopicC topic)) (let ((id - (concatenate 'string "\"id\":\"" (topicid topic) "\"")) + (concatenate 'string "\"id\":\"" (topic-id topic) "\"")) (itemIdentity (concatenate 'string "\"itemIdentities\":" (identifiers-to-json-string topic :what 'item-identifiers))) Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 21 12:53:44 2010 @@ -12,11 +12,14 @@ (:nicknames :d) (:import-from :exceptions duplicate-identifier-error) + (:import-from :exceptions + object-not-found-error) (:import-from :constants *xml-string*) (:import-from :constants *instance-psi*) (:export ;;classes + :TopicMapConstructC :TopicMapC :AssociationC :RoleC @@ -28,6 +31,7 @@ :SubjectLocatorC :TopicIdentificationC :TopicC + :FragmentC ;;methods, functions and macros :xtm-id @@ -40,6 +44,7 @@ :add-reifier :delete-reifier :find-item-by-revision + :find-most-recent-revision :themes :add-theme :delete-theme @@ -68,6 +73,7 @@ :topic-identifiers :add-topic-identifier :delete-topic-identifier + :topic-id :locators :add-locator :delete-locator @@ -92,6 +98,7 @@ :get-item-by-psi :get-item-by-item-identifier :get-item-by-locator + :get-item-by-content :string-integer-p :with-revision :get-latest-fragment-of-topic @@ -118,7 +125,18 @@ :make-construct :list-instanceOf :in-topicmap - :string-start-with + :string-starts-with + :get-fragments + :get-fragment + :get-all-revisions + :unique-id + :topic + :revision + :get-all-revisions-for-tm + :add-source-locator + :changed-p + :check-for-duplicate-identifiers + :find-item-by-content ;;globals :*TM-REVISION* @@ -596,6 +614,19 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun get-item-by-content (content &key (revision *TM-REVISION*)) + "Finds characteristics by their (atomic) content." + (flet + ((get-existing-instances (class-symbol) + (delete-if-not + #'(lambda (constr) + (find-item-by-revision constr revision)) + (elephant:get-instances-by-value class-symbol 'charvalue content)))) + (nconc (get-existing-instances 'OccurenceC) + (get-existing-instances 'NameC) + (get-existing-instances 'VariantC)))) + + (defmacro with-revision (revision &rest body) `(let ((*TM-REVISION* ,revision)) @@ -698,6 +729,11 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric check-for-duplicate-identifiers (construct) + (:documentation "Check for possibly duplicate identifiers and signal an + duplicate-identifier-error is such duplicates are found")) + + (defgeneric get-all-identifiers-of-construct (construct &key revision) (:documentation "Get all identifiers that a given construct has")) @@ -855,6 +891,12 @@ ;;; TopicMapconstructC +(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)) + (declare (ignore construct)) + ;do nothing + ) + + (defmethod get-all-characteristics ((parent-construct TopicC) (characteristic-symbol symbol)) (cond ((OccurrenceC-p characteristic-symbol) @@ -1109,6 +1151,30 @@ t)) +(defgeneric topic-id (construct &optional revision xtm-id) + (:documentation "Returns the primary id of this item + (= essentially the OID). If xtm-id is explicitly given, + returns one of the topic-ids in that TM + (which must then exist).") + (:method ((construct TopicC) &optional (xtm-id nil) (revision 0)) + (declare (type (or null string) xtm-id) (integer revision)) + (if xtm-id + (let ((possible-identifiers + (remove-if-not + #'(lambda(top-id) + (string= (xtm-id top-id) xtm-id)) + (topic-identifiers construct :revision revision)))) + (unless possible-identifiers + (error (make-condition + 'object-not-found-error + :message + (format nil "Could not find an object ~a in xtm-id ~a" + construct xtm-id)))) + (uri (first possible-identifiers))) + (concatenate 'string "t" (write-to-string (internal-id construct)))))) + + + (defgeneric topic-identifiers (construct &key revision) (:documentation "Returns the TopicIdentificationC-objects that correspond with the passed construct and the passed version.") @@ -2014,6 +2080,22 @@ ;;; ReifiableConstructC +(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)) + (dolist (id (get-all-identifiers-of-construct construct)) + (when (> + (length + (union + (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id)) + (union + (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id)) + (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id))))) + 1) + (error + (make-condition 'duplicate-identifier-error + :message (format nil "Duplicate Identifier ~a has been found" (uri id)) + :uri (uri id)))))) + + (defgeneric ReifiableConstructC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to ReifiableConstructC or one of its subtypes.") Modified: branches/new-datamodel/src/unit_tests/importer_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/importer_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/importer_test.lisp Sun Mar 21 12:53:44 2010 @@ -98,7 +98,7 @@ (is (= 1 (length t101-themes))) (is (string= - (topicid (first t101-themes) *TEST-TM*) + (topic-id (first t101-themes) *TEST-TM*) "t50a")))))) (test test-from-name-elem @@ -129,7 +129,7 @@ "http://psi.egovpt.org/types/long-name")) (is (themes t101-longname)) (is (string= - (topicid (first (themes t101-longname)) *TEST-TM*) + (topic-id (first (themes t101-longname)) *TEST-TM*) "t50a")) (is (eq t1-name t1-name-copy)) ;must be merged )))) @@ -233,10 +233,10 @@ ((12th-role (from-role-elem (nth 11 role-elems) revision))) (is (string= "t101" - (topicid + (topic-id (getf 12th-role :player) *TEST-TM*))) (is (string= "t62" - (topicid + (topic-id (getf 12th-role :instance-of) *TEST-TM*))))))) (test test-from-association-elem @@ -261,12 +261,12 @@ (is (= 2 (length (roles last-assoc)))) (is (= 1 (length (item-identifiers last-assoc)))) (is (string= "t300" - (topicid (player (first (roles 6th-assoc))) *TEST-TM*))) + (topic-id (player (first (roles 6th-assoc))) *TEST-TM*))) (is (string= "t63" - (topicid (instance-of (first (roles 6th-assoc))) + (topic-id (instance-of (first (roles 6th-assoc))) *TEST-TM*))) (is (string= "t301" - (topicid (player (first (roles last-assoc))) + (topic-id (player (first (roles last-assoc))) *TEST-TM*)))) ;(untrace datamodel:item-identifiers datamodel::filter-slot-value-by-revision)) ) @@ -302,8 +302,8 @@ (is (typep io-assoc 'AssociationC)) - (is (string= (topicid topic) - (topicid (player (second (roles io-assoc)))))))))) + (is (string= (topic-id topic) + (topic-id (player (second (roles io-assoc)))))))))) (let* ((t101-top (get-item-by-id "t101")) @@ -329,9 +329,9 @@ (is (= 1 (length role-101))) ;(is (= 1 (length (d::versions role-101)))) (is (string= "t3a" - (topicid (player (first (roles (parent (first role-101))))) *TEST-TM*))) + (topic-id (player (first (roles (parent (first role-101))))) *TEST-TM*))) (is (string= "type-instance" - (topicid (instance-of + (topic-id (instance-of (parent (first role-101))) "core.xtm"))) )))) Modified: branches/new-datamodel/src/unit_tests/json_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/json_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/json_test.lisp Sun Mar 21 12:53:44 2010 @@ -70,27 +70,27 @@ (let ((t50a (get-item-by-id "t50a"))) (let ((t50a-string (to-json-string t50a)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" ))) + (concatenate 'string "{\"id\":\"" (topic-id t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" ))) (is (string= t50a-string json-string))) (let ((t8 (get-item-by-id "t8"))) (let ((t8-string (to-json-string t8)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}"))) + (concatenate 'string "{\"id\":\"" (topic-id t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}"))) (is (string= t8-string json-string)))) (let ((t-topic (get-item-by-id "topic" :xtm-id "core.xtm"))) (let ((t-topic-string (to-json-string t-topic)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}"))) + (concatenate 'string "{\"id\":\"" (topic-id t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}"))) (is (string= t-topic-string json-string)))) (let ((t301 (get-item-by-id "t301"))) (let ((t301-string (to-json-string t301)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}"))) + (concatenate 'string "{\"id\":\"" (topic-id t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}"))) (is (string= t301-string json-string)))) (let ((t100 (get-item-by-id "t100"))) (let ((t100-string (to-json-string t100)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}"))) + (concatenate 'string "{\"id\":\"" (topic-id t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}"))) (is (string= t100-string json-string)))))))) @@ -156,9 +156,9 @@ (frag-topic (create-latest-fragment-of-topic "http://www.topicmaps.org/xtm/1.0/core.xtm#topic"))) (let ((frag-t100-string - (concatenate 'string "{\"topic\":{\"id\":\"" (d:topicid (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}")) + (concatenate 'string "{\"topic\":{\"id\":\"" (d:topic-id (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}")) (frag-topic-string - (concatenate 'string "{\"topic\":{\"id\":\"" (topicid (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}"))) + (concatenate 'string "{\"topic\":{\"id\":\"" (topic-id (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}"))) (is (string= frag-t100-string (to-json-string frag-t100))) (is (string= frag-topic-string (to-json-string frag-topic)))))))) @@ -181,7 +181,7 @@ (json:decode-json-from-string json-fragment)))) (let ((topic (getf fragment-list :topic))) (is (string= (getf topic :ID) - (d:topicid + (d:topic-id (d:identified-construct (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri "http://psi.egovpt.org/standard/Topic+Maps+2002"))))) (is-false (getf topic :itemIdentities)) @@ -294,7 +294,7 @@ "http://psi.egovpt.org/types/standardHasStatus")) (is-false (getf occurrence-1 :scopes)) (is (string= (getf occurrence-1 :resourceRef) - (concatenate 'string "#" (d:topicid ref-topic)))) + (concatenate 'string "#" (d:topic-id ref-topic)))) (is-false (getf occurrence-1 :resourceData)) (is-false (getf occurrence-2 :itemIdentities)) (is (= (length (getf occurrence-2 :type)) 1)) @@ -357,7 +357,7 @@ subjectIdentifier)))) (is-true topic) (is-false subjectLocators) - (is (string= (d:topicid topic) id)) + (is (string= (d:topic-id topic) id)) (cond ((string= subjectIdentifier "http://psi.egovpt.org/types/semanticstandard") (is (= (length itemIdentities) 1)) Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp Sun Mar 21 12:53:44 2010 @@ -31,7 +31,7 @@ (defun to-topicRef-elem-xtm1.0 (topic) (declare (TopicC topic)) (cxml:with-element "t:topicRef" - (cxml:attribute "xlink:href" (format nil "#~a" (topicid topic))))) + (cxml:attribute "xlink:href" (format nil "#~a" (topic-id topic))))) (defun to-reifier-elem-xtm1.0 (reifiable-construct) @@ -67,7 +67,7 @@ (let ((ref-topic (when (and (> (length characteristic-value) 0) (eql (elt characteristic-value 0) #\#)) (get-item-by-id (subseq characteristic-value 1))))) - (if ref-topic (concatenate 'string "#" (topicid ref-topic)) characteristic-value)))) + (if ref-topic (concatenate 'string "#" (topic-id ref-topic)) characteristic-value)))) (cxml:with-element "t:resourceData" (cxml:text characteristic-value))))) @@ -83,7 +83,7 @@ (declare (TopicC topic)) (cxml:with-element "t:instanceOf" (cxml:with-element "t:topicRef" - (cxml:attribute "xlink:href" (concatenate 'string "#" (topicid topic)))))) + (cxml:attribute "xlink:href" (concatenate 'string "#" (topic-id topic)))))) (defun to-subjectIdentity-elem-xtm1.0 (psis locator) @@ -145,7 +145,7 @@ "topic = element topic { id, instanceOf*, subjectIdentity, (baseName | occurrence)* }" (cxml:with-element "t:topic" - (cxml:attribute "id" (topicid topic)) + (cxml:attribute "id" (topic-id topic)) (when (list-instanceOf topic :tm *export-tm*) (map 'list #'to-instanceOf-elem-xtm1.0 (list-instanceOf topic :tm *export-tm*))) (when (or (psis topic) (locators topic)) @@ -188,7 +188,7 @@ with a topicid, psis and subjectLocators" (declare (TopicC topic)) (cxml:with-element "t:topic" - (cxml:attribute "id" (topicid topic)) + (cxml:attribute "id" (topic-id topic)) (to-subjectIdentity-elem-xtm1.0 (psis topic) (first (locators topic))))) Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp Sun Mar 21 12:53:44 2010 @@ -25,7 +25,7 @@ ;;TODO: this is pretty much of a hack that works only for local ;;references (cxml:attribute "href" - (format nil "#~a" (topicid topic))))) + (format nil "#~a" (topic-id topic))))) (defgeneric to-elem (instance) (:documentation "converts the Topic Maps construct instance to an XTM 2.0 element")) @@ -74,7 +74,7 @@ (get-item-by-id (subseq characteristic-value 1))))) (cxml:attribute "href" (if ref-topic - (concatenate 'string "#" (topicid ref-topic)) + (concatenate 'string "#" (topic-id ref-topic)) characteristic-value)))) (cxml:with-element "t:resourceData" (when (slot-boundp characteristic 'datatype) @@ -124,7 +124,7 @@ (itemIdentity | subjectLocator | subjectIdentifier)*, instanceOf?, (name | occurrence)* }" (cxml:with-element "t:topic" - (cxml:attribute "id" (topicid topic)) + (cxml:attribute "id" (topic-id topic)) (map 'list #'to-elem (item-identifiers topic)) (map 'list #'to-elem (locators topic)) (map 'list #'to-elem (psis topic)) @@ -132,7 +132,7 @@ (cxml:with-element "t:instanceOf" (loop for item in (list-instanceOf topic :tm *export-tm*) do (cxml:with-element "t:topicRef" - (cxml:attribute "href" (concatenate 'string "#" (topicid item))))))) + (cxml:attribute "href" (concatenate 'string "#" (topic-id item))))))) (map 'list #'to-elem (names topic)) (map 'list #'to-elem (occurrences topic)))) @@ -142,7 +142,7 @@ with a topicid, a subjectLocator and an itemIdentity element" (declare (TopicC topic)) (cxml:with-element "t:topic" - (cxml:attribute "id" (topicid topic)) + (cxml:attribute "id" (topic-id topic)) (map 'list #'to-elem (psis topic)) (map 'list #'to-elem (item-identifiers topic)) (map 'list #'to-elem (locators topic))))

1 0

[isidorus-cvs] r237 - branches/new-datamodel/src/model
by Lukas Giessmann 21 Mar '10

21 Mar '10

Author: lgiessmann Date: Sun Mar 21 05:14:10 2010 New Revision: 237 Log: new-datamodel: fixed some sections that cauesd errors with the "changes.lisp" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 21 05:14:10 2010 @@ -14,6 +14,8 @@ duplicate-identifier-error) (:import-from :constants *xml-string*) + (:import-from :constants + *instance-psi*) (:export ;;classes :TopicMapC :AssociationC @@ -114,6 +116,9 @@ :TopicMapConstructC-p :VersionedConstructC-p :make-construct + :list-instanceOf + :in-topicmap + :string-start-with ;;globals :*TM-REVISION* @@ -315,9 +320,11 @@ (elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC) ((topics :associate (TopicC in-topicmaps) :many-to-many t + :accessor topics :documentation "List of topics that explicitly belong to this TM.") (associations :associate (AssociationC in-topicmaps) :many-to-many t + :accessor associations :documentation "List of associations that belong to this TM.")) (:documentation "Represnets a topic map.")) @@ -673,7 +680,28 @@ (merge-constructs merged-construct construct-to-be-merged))))) +(defgeneric internal-id (construct) + (:documentation "Returns the internal id that uniquely identifies a + construct (currently simply its OID).")) + + +(defmethod internal-id ((construct TopicMapConstructC)) + (slot-value construct (find-symbol "OID" 'elephant))) + + +(defun string-starts-with (str prefix) + "Checks if string str starts with a given prefix." + (declare (string str prefix)) + (string= str prefix :start1 0 :end1 + (min (length prefix) + (length str)))) + + ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric get-all-identifiers-of-construct (construct &key revision) + (:documentation "Get all identifiers that a given construct has")) + + (defgeneric get-all-characteristics (parent-construct characteristic-symbol) (:documentation "Returns all characterisitcs of the passed type the parent construct was ever associated with.")) @@ -700,7 +728,7 @@ (defgeneric in-topicmaps (construct &key revision) - (:documentation "Returns all TopicMapS-obejcts where the constrict is + (:documentation "Returns all TopicMaps-obejcts where the construct is contained in.")) @@ -1250,6 +1278,14 @@ construct))) +(defmethod get-all-identifiers-of-construct ((construct TopicC) + &key (revision 0)) + (declare (integer revision)) + (append (psis construct :revision revision) + (locators construct :revision revision) + (item-identifiers construct :revision revision))) + + (defgeneric names (construct &key revision) (:documentation "Returns the NameC-objects that correspond with the passed construct and the passed version.") @@ -1489,6 +1525,30 @@ :error-if-nil error-if-nil)) + +(defgeneric list-instanceOf (topic &key tm) + (:documentation "Generates a list of all topics that this topic is an + instance of, optionally filtered by a topic map")) + + +(defmethod list-instanceOf ((topic TopicC) &key (tm nil)) + (remove-if + #'null + (map 'list #'(lambda(x) + (when (loop for psi in (psis (instance-of x)) + when (string= (uri psi) constants:*instance-psi*) + return t) + (loop for role in (roles (parent x)) + when (not (eq role x)) + return (player role)))) + (if tm + (remove-if-not + (lambda (role) + (in-topicmap tm (parent role))) + (player-in-roles topic)) + (player-in-roles topic))))) + + ;;; CharacteristicC (defgeneric CharacteristicC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to CharacteristicC @@ -2135,6 +2195,13 @@ (mark-as-deleted assoc-to-delete :revision revision)) construct))) + +(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC) + &key (revision 0)) + (declare (integer revision)) + (item-identifiers construct :revision revision)) + + ;;; TypableC (defgeneric TypableC-p (class-symbol) (:documentation "Returns t if the passed class is equal to TypableC or @@ -2343,20 +2410,6 @@ (remove-association construct 'associations assoc))) -(defgeneric topics (construct &key revision) - (:documentation "Returns all TopicC-objects that are contained in the tm.") - (:method ((construct TopicMapC) &key (revision 0)) - (filter-slot-value-by-revision construct 'topics - :start-revision revision))) - - -(defgeneric associations (construct &key revision) - (:documentation "Returns all AssociationC-objects that are contained in the tm.") - (:method ((construct TopicMapC) &key (revision 0)) - (filter-slot-value-by-revision construct 'associations - :start-revision revision))) - - (defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) (add-association construct 'topics construct-to-add)) @@ -2374,6 +2427,21 @@ (remove-association construct 'associations construct-to-delete)) +(defgeneric in-topicmap (tm construct &key revision) + (:documentation "Is a given construct (topic or assiciation) in this + topic map?")) + + +(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0)) + (when (find-item-by-revision top revision) + (find (internal-id top) (topics tm) :test #'= :key #'internal-id))) + + +(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0)) + (when (find-item-by-revision ass revision) + (find (internal-id ass) (associations tm) :test #'= :key #'internal-id))) + + ;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun make-construct (class-symbol &rest args) "Creates a new topic map construct if necessary or @@ -2386,7 +2454,7 @@ ((PointerC-p class-symbol) (make-pointer class-symbol (getf args :uri) args)) ((CharacteristicC-p class-symbol) - (make-characteristic class-symbol (getf args :charvalue) args)) + (make-characteristic class-symbol args)) ((TopicC-p class-symbol) (make-topic args)) ((TopicMapC-p class-symbol)

1 0

[isidorus-cvs] r236 - branches/new-datamodel/src/model
by Lukas Giessmann 21 Mar '10

21 Mar '10

Author: lgiessmann Date: Sun Mar 21 04:36:20 2010 New Revision: 236 Log: new-datamodel: optimized "make-construct" Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Sun Mar 21 04:36:20 2010 @@ -1,4 +1,4 @@ -#;;+----------------------------------------------------------------------------- +;;+----------------------------------------------------------------------------- ;;+ Isidorus ;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann ;;+ Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 21 04:36:20 2010 @@ -1645,7 +1645,7 @@ (eql class-symbol 'NameC))) -(defgeneric initialize-name (construct variants &key start-revision) +(defgeneric complete-name (construct variants &key start-revision) (:documentation "Adds all given variants to the passed construct.") (:method ((construct NameC) (variants list) &key (start-revision *TM-REVISION*)) @@ -1966,7 +1966,7 @@ (CharacteristicC-p class-symbol)))) -(defgeneric initialize-reifiable (construct item-identifiers reifier +(defgeneric complete-reifiable (construct item-identifiers reifier &key start-revision) (:documentation "Adds all item-identifiers and the reifier to the passed construct.") @@ -2146,7 +2146,7 @@ (CharacteristicC-p class-symbol)))) -(defgeneric initialize-typable (construct instance-of &key start-revision) +(defgeneric complete-typable (construct instance-of &key start-revision) (:documentation "Adds the passed instance-of to the given construct.") (:method ((construct TypableC) instance-of &key (start-revision *TM-REVISION*)) @@ -2176,7 +2176,7 @@ (CharacteristicC-p class-symbol)))) -(defgeneric initialize-scopable (construct themes &key start-revision) +(defgeneric complete-scopable (construct themes &key start-revision) (:documentation "Adds all passed themes to the given construct.") (:method ((construct ScopableC) (themes list) &key (start-revision *TM-REVISION*)) @@ -2394,17 +2394,25 @@ ((RoleC-p class-symbol) (make-role args)) ((AssociationC-p class-symbol) - (make-association args))))) - construct)) + (make-association args)))) + (start-revision (getf args :start-revision))) + (when (typep construct 'TypableC) + (complete-typable construct (getf args :instance-of) + :start-revision start-revision)) + (when (typep construct 'ScopableC) + (complete-scopable construct (getf args :themes) + :start-revision start-revision)) + (if (typep construct 'ReifiableConstructC) + (complete-reifiable construct (getf args :item-identtifiers) + (getf args :reifier) :start-revision start-revision) + construct))) (defun make-association (args) "Returns an association object. If the association has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" - (let ((item-identifiers (getf (first args) :item-identifiers)) - (reifier (getf (first args) :reifier)) - (instance-of (getf (first args) :instance-of)) + (let ((instance-of (getf (first args) :instance-of)) (start-revision (getf (first args) :start-revision)) (themes (get (first args) :themes)) (roles (get (first args) :roles)) @@ -2427,23 +2435,16 @@ (if existing-association existing-association (make-instance 'AssociationC))))) - (initialize-typable association instance-of :start-revision - start-revision) (dolist (role roles) (add-role association role :revision start-revision)) - (dolist (theme themes) - (add-theme association theme :revision start-revision)) - (initialize-reifiable association item-identifiers reifier - :start-revision start-revision)))) + association))) (defun make-role (args) "Returns a role object. If the role has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" - (let ((item-identifiers (getf args :item-identifiers)) - (reifier (getf args :reifier)) - (parent (getf args :parent)) + (let ((parent (getf args :parent)) (instance-of (getf args :instance-of)) (player (getf args :player)) (start-revision (getf args :start-revision)) @@ -2467,11 +2468,9 @@ (make-instance 'RoleC))))) (when player (add-player role player :revision start-revision)) - (initialize-typable role instance-of :start-revision start-revision) (when parent (add-parent role parent :revision start-revision)) - (initialize-reifiable role item-identifiers reifier - :start-revision start-revision)))) + role))) (defun make-tm (args) @@ -2505,8 +2504,7 @@ (make-instance 'TopicMapC)))))) (dolist (top-or-assoc (union topics assocs)) (add-to-tm tm top-or-assoc)) - (initialize-reifiable tm item-identifiers reifier - :start-revision start-revision)))) + tm))) (defun make-topic (&rest args) @@ -2543,9 +2541,6 @@ (t (make-instance 'TopicC)))))) (let ((merged-topic topic)) - (setf merged-topic - (initialize-reifiable topic item-identifiers nil - :start-revision start-revision)) (dolist (psi psis) (setf merged-topic (add-psi merged-topic psi :revision start-revision))) @@ -2572,9 +2567,7 @@ (instance-of (getf (first args) :instance-of)) (themes (getf (first args) :themes)) (variants (getf (first args) :variants)) - (reifier (getf (first args) :reifier)) (parent (getf (first args) :parent)) - (item-identifiers (getf (first args) :item-identifiers)) (err "From make-characteristic(): ")) (unless start-revision (error "~astart-revision must be set" err)) (unless charvalue (error "~acharvalue must be set" err)) @@ -2599,14 +2592,10 @@ existing-characteristic (make-instance class-symbol :charvalue charvalue :datatype datatype))))) - (initialize-scopable characteristic themes :start-revision start-revision) - (initialize-typable characteristic instance-of - :start-revision start-revision) - (initialize-name characteristic variants :start-revision start-revision) + (complete-name characteristic variants :start-revision start-revision) (when parent (add-parent characteristic parent :revision start-revision)) - (initialize-reifiable characteristic item-identifiers - reifier :start-revision start-revision)))) + characteristic))) (defun make-pointer (class-symbol &rest args)

1 0

[isidorus-cvs] r235 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 20 Mar '10

20 Mar '10

Author: lgiessmann Date: Sat Mar 20 18:00:40 2010 New Revision: 235 Log: new-datamodel: finalized "make-construct" 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 Sat Mar 20 18:00:40 2010 @@ -663,6 +663,16 @@ (condition () nil))) +(defun merge-all-constructs(constructs-to-be-merged) + "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))))) + + ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric get-all-characteristics (parent-construct characteristic-symbol) (:documentation "Returns all characterisitcs of the passed type the parent @@ -2378,29 +2388,104 @@ ((CharacteristicC-p class-symbol) (make-characteristic class-symbol (getf args :charvalue) args)) ((TopicC-p class-symbol) - (make-topic args))))) + (make-topic args)) + ((TopicMapC-p class-symbol) + (make-tm args)) + ((RoleC-p class-symbol) + (make-role args)) + ((AssociationC-p class-symbol) + (make-association args))))) construct)) -(defun merge-all-constructs(constructs-to-be-merged) - "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))))) +(defun make-association (args) + "Returns an association object. If the association has already existed the + existing one is returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((item-identifiers (getf (first args) :item-identifiers)) + (reifier (getf (first args) :reifier)) + (instance-of (getf (first args) :instance-of)) + (start-revision (getf (first args) :start-revision)) + (themes (get (first args) :themes)) + (roles (get (first args) :roles)) + (err "From make-association(): ")) + (unless start-revision (error "~astart-revision must be set" err)) + (unless roles (error "~aroles must be set" err)) + (unless instance-of (error "~ainstance-of must be set" err)) + (let ((association + (let ((existing-association + (remove-if + #'null + (map 'list #'(lambda(existing-association) + (when (equivalent-construct + existing-association + :start-revision start-revision + :roles roles :themes themes + :instance-of instance-of) + existing-association)) + (elephant:get-instances-by-class 'AssociationC))))) + (if existing-association + existing-association + (make-instance 'AssociationC))))) + (initialize-typable association instance-of :start-revision + start-revision) + (dolist (role roles) + (add-role association role :revision start-revision)) + (dolist (theme themes) + (add-theme association theme :revision start-revision)) + (initialize-reifiable association item-identifiers reifier + :start-revision start-revision)))) -(defun make-tm (&rest args) +(defun make-role (args) + "Returns a role object. If the role has already existed the + existing one is returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((item-identifiers (getf args :item-identifiers)) + (reifier (getf args :reifier)) + (parent (getf args :parent)) + (instance-of (getf args :instance-of)) + (player (getf args :player)) + (start-revision (getf args :start-revision)) + (err "From make-role(): ")) + (unless start-revision (error "~astart-revision must be set" err)) + (unless instance-of (error "~ainstance-of must be set" err)) + (unless player (error "~aplayer must be set" err)) + (let ((role + (let ((existing-role + (remove-if + #'null + (map 'list #'(lambda(existing-role) + (when (equivalent-construct + existing-role + :player player + :instance-of instance-of) + existing-role)) + (slot-p parent 'roles))))) + (if existing-role + existing-role + (make-instance 'RoleC))))) + (when player + (add-player role player :revision start-revision)) + (initialize-typable role instance-of :start-revision start-revision) + (when parent + (add-parent role parent :revision start-revision)) + (initialize-reifiable role item-identifiers reifier + :start-revision start-revision)))) + + +(defun make-tm (args) "Returns a topic map object. If the topic map has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" - (let ((item-identifiers (getf (first args) :item-identifiers)) - (reifier (getf (first args) :reifier)) - (topics (getf (first args) :topics)) - (assocs (getf (first args) :associations)) - (start-revision (getf (first args) :start-revision))) + (let ((item-identifiers (getf args :item-identifiers)) + (reifier (getf args :reifier)) + (topics (getf args :topics)) + (assocs (getf args :associations)) + (start-revision (getf args :start-revision)) + (err "From make-tm(): ")) + (unless item-identifiers (error "~aitem-identifiers must be set" err)) + (unless start-revision (error "~astart-revision must be set" err)) (let ((tm (let ((existing-tms (remove-if @@ -2420,21 +2505,24 @@ (make-instance 'TopicMapC)))))) (dolist (top-or-assoc (union topics assocs)) (add-to-tm tm top-or-assoc)) - (add-to-version-history tm :start-revision start-revision) - tm))) + (initialize-reifiable tm item-identifiers reifier + :start-revision start-revision)))) (defun make-topic (&rest args) "Returns a topic object. If the topic has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" - (let ((start-revision (getf (first args) :start-revision)) - (psis (getf (first args) :psis)) - (locators (getf (first args) :locators)) - (item-identifiers (getf (first args) :item-identifiers)) - (topic-identifiers (getf (first args) :topic-identifiers)) - (names (getf (first args) :names)) - (occurrences (getf (first args) :occurrences))) + (let ((start-revision (getf args :start-revision)) + (psis (getf args :psis)) + (locators (getf args :locators)) + (item-identifiers (getf args :item-identifiers)) + (topic-identifiers (getf args :topic-identifiers)) + (names (getf args :names)) + (occurrences (getf args :occurrences)) + (err "From make-topic(): ")) + (unless topic-identifiers (error "~atopic-identifiers must be set" err)) + (unless start-revision (error "~astart-revision must be set" err)) (let ((topic (let ((existing-topics (remove-if @@ -2454,9 +2542,10 @@ (first existing-topics)) (t (make-instance 'TopicC)))))) - (initialize-reifiable topic item-identifiers nil - :start-revision start-revision) (let ((merged-topic topic)) + (setf merged-topic + (initialize-reifiable topic item-identifiers nil + :start-revision start-revision)) (dolist (psi psis) (setf merged-topic (add-psi merged-topic psi :revision start-revision))) @@ -2464,10 +2553,10 @@ (setf merged-topic (add-locator merged-topic locator :revision start-revision))) (dolist (name names) - (setf merged-topic (add-name topic name :revision start-revision))) + (setf merged-topic (add-name merged-topic name + :revision start-revision))) (dolist (occ occurrences) (add-occurrence merged-topic occ :revision start-revision)) - (add-to-version-history merged-topic :start-revision start-revision) merged-topic)))) @@ -2484,11 +2573,17 @@ (themes (getf (first args) :themes)) (variants (getf (first args) :variants)) (reifier (getf (first args) :reifier)) - (parent-construct (getf (first args) :parent-construct)) - (item-identifiers (getf (first args) :item-identifiers))) + (parent (getf (first args) :parent)) + (item-identifiers (getf (first args) :item-identifiers)) + (err "From make-characteristic(): ")) + (unless start-revision (error "~astart-revision must be set" err)) + (unless charvalue (error "~acharvalue must be set" err)) + (when (and (or (OccurrenceC-p class-symbol) (NameC-p class-symbol)) + (not instance-of)) + (error "~ainstance-of must be set" err)) (let ((characteristic (let ((existing-characteristic - (when parent-construct + (when parent (remove-if #'null (map 'list #'(lambda(existing-characteristic) @@ -2499,26 +2594,19 @@ :charvalue charvalue :themes themes :instance-of instance-of) existing-characteristic)) - (get-all-characteristics parent-construct - class-symbol)))))) + (get-all-characteristics parent class-symbol)))))) (if existing-characteristic existing-characteristic (make-instance class-symbol :charvalue charvalue :datatype datatype))))) - (let ((merged-characteristic characteristic)) - (setf merged-characteristic - (initialize-reifiable merged-characteristic item-identifiers - reifier :start-revision start-revision)) - (initialize-scopable merged-characteristic themes - :start-revision start-revision) - (initialize-typable merged-characteristic instance-of - :start-revision start-revision) - (initialize-name merged-characteristic variants - :start-revision start-revision) - (when parent-construct - (add-parent merged-characteristic parent-construct - :revision start-revision)) - merged-characteristic)))) + (initialize-scopable characteristic themes :start-revision start-revision) + (initialize-typable characteristic instance-of + :start-revision start-revision) + (initialize-name characteristic variants :start-revision start-revision) + (when parent + (add-parent characteristic parent :revision start-revision)) + (initialize-reifiable characteristic item-identifiers + reifier :start-revision start-revision)))) (defun make-pointer (class-symbol &rest args) @@ -2528,7 +2616,10 @@ (let ((uri (getf (first args) :uri)) (xtm-id (getf (first args) :xtm-id)) (start-revision (getf (first args) :start-revision)) - (identified-construct (getf (first args) :identified-construct))) + (identified-construct (getf (first args) :identified-construct)) + (err "From make-pointer(): ")) + (when (and identified-construct (not start-revision)) + (error "~astart-revision must be set" err)) (let ((identifier (let ((existing-pointer (remove-if 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 Sat Mar 20 18:00:40 2010 @@ -61,11 +61,8 @@ :test-class-p)) -;;TODO: test merge-constructs when merging was caused by an item-dentifier, -;; a psi, a subject-locator, a topic-id -;;TODO: test merge-constructs when merging was caused by reifiers -;; (occurrences, names, variants, associations, roles) -;;TODO: test ReifiableConstructC --> reifier has to be merged +;;TODO: test make-construct +;;TODO: test merge-constructs

1 0

[isidorus-cvs] r234 - in branches/new-datamodel/src: json model rest_interface unit_tests xml/rdf xml/xtm
by Lukas Giessmann 20 Mar '10

20 Mar '10

Author: lgiessmann Date: Sat Mar 20 16:33:55 2010 New Revision: 234 Log: new-datamodel: implemented "make-topic" and other helper functions for "make-cosntruct"; fixed a bug in "add-topic-identifier", "add-psi", "add-item-identifier" and "add-locator" with "merge-constructs" Modified: branches/new-datamodel/src/json/json_importer.lisp branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/rest_interface/rest-interface.lisp branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp branches/new-datamodel/src/xml/rdf/importer.lisp branches/new-datamodel/src/xml/xtm/setup.lisp Modified: branches/new-datamodel/src/json/json_importer.lisp ============================================================================== --- branches/new-datamodel/src/json/json_importer.lisp (original) +++ branches/new-datamodel/src/json/json_importer.lisp Sat Mar 20 16:33:55 2010 @@ -32,13 +32,19 @@ (topicStubs-values (getf fragment-values :topicStubs)) (associations-values (getf fragment-values :associations)) (rev (get-revision))) ; creates a new revision, equal for all elements of the passed fragment - (elephant:ensure-transaction (:txn-nosync nil) - (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) - (loop for topicStub-values in (append topicStubs-values (list topic-values)) - do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) - (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) - (loop for association-values in associations-values - do (json-to-association association-values rev :tm xml-importer::tm)))))))) + (let ((psi-of-topic + (let ((psi-uris (getf topic-values :subjectIdentifiers))) + (when psi-uris + (first psi-uris))))) + (elephant:ensure-transaction (:txn-nosync nil) + (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) + (loop for topicStub-values in (append topicStubs-values (list topic-values)) + do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) + (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) + (loop for association-values in associations-values + do (json-to-association association-values rev :tm xml-importer::tm)))) + (when psi-of-topic + (create-latest-fragment-of-topic psi-of-topic))))))) (defun json-to-association (json-decoded-list start-revision Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Sat Mar 20 16:33:55 2010 @@ -277,7 +277,7 @@ (defun create-latest-fragment-of-topic (topic-psi) - "returns the latest fragment of the passed topic-psi" + "Returns the latest fragment of the passed topic-psi" (declare (string topic-psi)) (let ((topic (get-item-by-psi topic-psi))) @@ -299,4 +299,18 @@ :revision start-revision :associations (find-associations-for-topic topic) :referenced-topics (find-referenced-topics topic) - :topic topic))))))) \ No newline at end of file + :topic topic))))))) + + +(defun get-latest-fragment-of-topic (topic-psi) + "Returns the latest existing fragment of the passed topic-psi." + (declare (string topic-psi)) + (let ((topic + (get-item-by-psi topic-psi))) + (when topic + (let ((existing-fragments + (elephant:get-instances-by-value 'FragmentC 'topic topic))) + (when existing-fragments + (first (sort existing-fragments + #'(lambda(frg-1 frg-2) + (> (revision frg-1) (revision frg-2)))))))))) \ No newline at end of file Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sat Mar 20 16:33:55 2010 @@ -92,6 +92,8 @@ :get-item-by-locator :string-integer-p :with-revision + :get-latest-fragment-of-topic + :create-latest-fragment-of-topic :PointerC-p :IdentifierC-p :SubjectLocatorC-p @@ -122,9 +124,10 @@ -;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier -;; (can merge the parent construct and the parent's parent construct), -;; add-psi, add-locator +;;TODO: check merge-constructs in add-topic-identifier, +;; add-item-identifier/add-reifier (can merge the parent construct +;; and the parent's parent construct), add-psi, add-locator +;; (--> duplicate-identifier-error) ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -1007,19 +1010,22 @@ (defmethod equivalent-construct ((construct TopicC) &key (start-revision 0) (psis nil) - (locators nil) (item-identifiers nil)) + (locators nil) (item-identifiers nil) + (topic-identifiers nil)) "Isidorus handles Topic-equality only by the topic's identifiers 'psis', 'subject locators' and 'item identifiers'. Names and occurences are not checked becuase we don't know when a topic is finalized and owns all its charactersitics. T is returned if the topic owns one of the given identifier-URIs." - (declare (integer start-revision) (list psis locators item-identifiers)) + (declare (integer start-revision) (list psis locators item-identifiers + topic-identifiers)) (when (intersection (union (union (psis construct :revision start-revision) (locators construct :revision start-revision)) - (item-identifiers construct :revision start-revision)) - (union (union psis locators) item-identifiers)) + (union (item-identifiers construct :revision start-revision) + (topic-identifiers construct :revision start-revision))) + (union (union psis locators) (union item-identifiers topic-identifiers))) t)) @@ -1088,24 +1094,25 @@ (let ((id-owner (identified-construct topic-identifier))) (when (not (eql id-owner construct)) id-owner)))) - (cond (construct-to-be-merged - (merge-constructs construct construct-to-be-merged :revision revision)) - ((find topic-identifier all-ids) - (let ((ti-assoc (loop for ti-assoc in (slot-p construct - 'topic-identifiers) - when (eql (identifier ti-assoc) - topic-identifier) - return ti-assoc))) - (add-to-version-history ti-assoc :start-revision revision))) - (t - (let ((assoc - (make-instance 'TopicIdAssociationC - :parent-construct construct - :identifier topic-identifier))) - (add-to-version-history assoc :start-revision revision)))) - (when (typep construct 'TopicC) - (add-to-version-history construct :start-revision revision)) - construct))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find topic-identifier all-ids) + (let ((ti-assoc (loop for ti-assoc in (slot-p construct + 'topic-identifiers) + when (eql (identifier ti-assoc) + topic-identifier) + return ti-assoc))) + (add-to-version-history ti-assoc :start-revision revision))) + (t + (let ((assoc (make-instance 'TopicIdAssociationC + :parent-construct construct + :identifier topic-identifier))) + (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) (defgeneric delete-topic-identifier (construct topic-identifier &key revision) @@ -1144,22 +1151,23 @@ (let ((id-owner (identified-construct psi))) (when (not (eql id-owner construct)) id-owner)))) - (cond (construct-to-be-merged - (merge-constructs construct construct-to-be-merged - :revision revision)) - ((find psi all-ids) - (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) - when (eql (identifier psi-assoc) psi) - return psi-assoc))) - (add-to-version-history psi-assoc :start-revision revision))) - (t - (let ((assoc - (make-instance 'PersistentIdAssociationC - :parent-construct construct - :identifier psi))) - (add-to-version-history assoc :start-revision revision)))) - (add-to-version-history construct :start-revision revision) - construct))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find psi all-ids) + (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) + when (eql (identifier psi-assoc) psi) + return psi-assoc))) + (add-to-version-history psi-assoc :start-revision revision))) + (t + (let ((assoc (make-instance 'PersistentIdAssociationC + :parent-construct construct + :identifier psi))) + (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) (defgeneric delete-psi (construct psi &key revision) @@ -1198,22 +1206,25 @@ (let ((id-owner (identified-construct locator))) (when (not (eql id-owner construct)) id-owner)))) - (cond (construct-to-be-merged - (merge-constructs construct construct-to-be-merged - :revision revision)) - ((find locator all-ids) - (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators) - when (eql (identifier loc-assoc) locator) - return loc-assoc))) - (add-to-version-history loc-assoc :start-revision revision))) - (t - (let ((assoc - (make-instance 'SubjectLocatorAssociationC - :parent-construct construct - :identifier locator))) - (add-to-version-history assoc :start-revision revision)))) - (add-to-version-history construct :start-revision revision) - construct))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find locator all-ids) + (let ((loc-assoc + (loop for loc-assoc in (slot-p construct 'locators) + when (eql (identifier loc-assoc) locator) + return loc-assoc))) + (add-to-version-history loc-assoc :start-revision revision))) + (t + (let ((assoc + (make-instance 'SubjectLocatorAssociationC + :parent-construct construct + :identifier locator))) + (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) (defgeneric delete-locator (construct locator &key revision) @@ -1480,21 +1491,20 @@ (defmethod equivalent-construct ((construct CharacteristicC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (charvalue "") + &key (start-revision 0) (charvalue "") (instance-of nil) (themes nil)) "Equality rule: Characteristics are equal if charvalue, themes and instance-of are equal." - (declare (string charvalue) (list themes item-identifiers) + (declare (string charvalue) (list themes) (integer start-revision) - (type (or null TopicC) instance-of reifier)) - (or (and (string= (charvalue construct) charvalue) - (equivalent-scopable-construct construct themes - :start-revision start-revision) - (equivalent-typable-construct construct instance-of - :start-revision start-revision)) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision))) + (type (or null TopicC) instance-of)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and (string= (charvalue construct) charvalue) + (equivalent-scopable-construct construct themes + :start-revision start-revision) + (equivalent-typable-construct construct instance-of + :start-revision start-revision))) (defmethod delete-construct :before ((construct CharacteristicC)) @@ -1578,20 +1588,18 @@ (defmethod equivalent-construct ((construct OccurrenceC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (charvalue "") + &key (start-revision 0) (charvalue "") (themes nil) (instance-of nil) (datatype "")) "Occurrences are equal if their charvalue, datatype, themes and instance-of properties are equal." - (declare (type (or null TopicC) instance-of reifier) (string datatype) - (list item-identifiers) + (declare (type (or null TopicC) instance-of) (string datatype) (ignorable start-revision charvalue themes instance-of)) (let ((equivalent-characteristic (call-next-method))) - (or (and equivalent-characteristic - (string= (datatype construct) datatype)) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision)))) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and equivalent-characteristic + (string= (datatype construct) datatype)))) ;;; VariantC @@ -1602,19 +1610,16 @@ (defmethod equivalent-construct ((construct VariantC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (charvalue "") + &key (start-revision 0) (charvalue "") (themes nil) (datatype "")) "Variants are equal if their charvalue, datatype and themes properties are equal." - (declare (string datatype) (list item-identifiers) - (ignorable start-revision charvalue themes) - (type (or null TopicC) reifier)) + (declare (string datatype) (ignorable start-revision charvalue themes)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them (let ((equivalent-characteristic (call-next-method))) - (or (and equivalent-characteristic - (string= (datatype construct) datatype)) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision)))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) ;;; NameC @@ -1630,15 +1635,22 @@ (eql class-symbol 'NameC))) +(defgeneric initialize-name (construct variants &key start-revision) + (:documentation "Adds all given variants to the passed construct.") + (:method ((construct NameC) (variants list) + &key (start-revision *TM-REVISION*)) + (dolist (variant variants) + (add-variant construct variant :revision start-revision)) + construct)) + + (defmethod equivalent-construct ((construct NameC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (charvalue "") + &key (start-revision 0) (charvalue "") (themes nil) (instance-of nil)) "Names are equal if their charvalue, instance-of and themes properties are equal." (declare (type (or null TopicC) instance-of) - (ignorable start-revision charvalue instance-of themes - reifier item-identifiers)) + (ignorable start-revision charvalue instance-of themes)) (call-next-method)) @@ -1709,22 +1721,20 @@ (defmethod equivalent-construct ((construct AssociationC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (roles nil) + &key (start-revision 0) (roles nil) (instance-of nil) (themes nil)) "Associations are equal if their themes, instance-of and roles properties are equal." - (declare (integer start-revision) (list roles themes item-identifiers) - (type (or null TopicC) instance-of reifier)) - (or - (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)) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision))) + (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))) (defmethod delete-construct :before ((construct AssociationC)) @@ -1800,18 +1810,15 @@ (defmethod equivalent-construct ((construct RoleC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (player nil) + &key (start-revision 0) (player nil) (instance-of nil)) "Roles are equal if their instance-of and player properties are equal." - (declare (integer start-revision) - (type (or null TopicC) player instance-of reifier) - (list item-identifiers)) - (or (and (equivalent-typable-construct construct instance-of - :start-revision start-revision) - (eql player (player construct :revision start-revision))) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision))) + (declare (integer start-revision) (type (or null TopicC) player instance-of)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (eql player (player construct :revision start-revision)))) (defmethod delete-construct :before ((construct RoleC)) @@ -1949,6 +1956,25 @@ (CharacteristicC-p class-symbol)))) +(defgeneric initialize-reifiable (construct item-identifiers reifier + &key start-revision) + (:documentation "Adds all item-identifiers and the reifier to the passed + construct.") + (:method ((construct ReifiableConstructC) item-identifiers reifier + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision) (list item-identifiers) + (type (or null TopicC) reifier)) + (let ((merged-construct construct)) + (dolist (ii item-identifiers) + (setf merged-construct + (add-item-identifier merged-construct ii + :revision start-revision))) + (when reifier + (setf merged-construct (add-reifier merged-construct reifier + :revision start-revision))) + merged-construct))) + + (defgeneric equivalent-reifiable-construct (construct reifier item-identifiers &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e @@ -2010,26 +2036,27 @@ (let ((id-owner (identified-construct item-identifier))) (when (not (eql id-owner construct)) id-owner)))) - (cond (construct-to-be-merged - (merge-constructs construct construct-to-be-merged - :revision revision)) - ((find item-identifier all-ids) - (let ((ii-assoc (loop for ii-assoc in (slot-p construct - 'item-identifiers) - when (eql (identifier ii-assoc) item-identifier) - return ii-assoc))) - (add-to-version-history ii-assoc :start-revision revision))) - (t - (let ((assoc - (make-instance 'ItemIdAssociationC - :parent-construct construct - :identifier item-identifier))) - (add-to-version-history assoc :start-revision revision)))) - (when (or (typep construct 'TopicC) - (typep construct 'AssociationC) - (typep construct 'TopicMapC)) - (add-to-version-history construct :start-revision revision)) - construct))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find item-identifier all-ids) + (let ((ii-assoc + (loop for ii-assoc in (slot-p construct 'item-identifiers) + when (eql (identifier ii-assoc) item-identifier) + return ii-assoc))) + (add-to-version-history ii-assoc :start-revision revision))) + (t + (let ((assoc (make-instance 'ItemIdAssociationC + :parent-construct construct + :identifier item-identifier))) + (add-to-version-history assoc :start-revision revision)))) + (when (or (typep merged-construct 'TopicC) + (typep merged-construct 'AssociationC) + (typep merged-construct 'TopicMapC)) + (add-to-version-history merged-construct :start-revision revision)) + merged-construct)))) (defgeneric delete-item-identifier (construct item-identifier &key revision) @@ -2062,28 +2089,28 @@ :revision revision))) (when inner-construct (list inner-construct))))) - (cond ((find construct all-constructs) - (let ((reifier-assoc - (loop for reifier-assoc in - (slot-p merged-reifier-topic 'reified-construct) - when (eql (reifiable-construct reifier-assoc) - construct) - return reifier-assoc))) - (add-to-version-history reifier-assoc :start-revision revision) - construct)) - (all-constructs - (merge-constructs (first all-constructs) construct)) - (t - (let ((assoc - (make-instance 'ReifierAssociationC - :reifiable-construct construct - :reifier-topic merged-reifier-topic))) - (add-to-version-history assoc :start-revision revision)))) - (when (or (typep construct 'TopicC) - (typep construct 'AssociationC) - (typep construct 'TopicMapC)) - (add-to-version-history construct :start-revision revision)) - construct)))) + (let ((merged-construct construct)) + (cond ((find construct all-constructs) + (let ((reifier-assoc + (loop for reifier-assoc in + (slot-p merged-reifier-topic 'reified-construct) + when (eql (reifiable-construct reifier-assoc) + construct) + return reifier-assoc))) + (add-to-version-history reifier-assoc + :start-revision revision))) + (all-constructs + (merge-constructs (first all-constructs) construct)) + (t + (let ((assoc (make-instance 'ReifierAssociationC + :reifiable-construct construct + :reifier-topic merged-reifier-topic))) + (add-to-version-history assoc :start-revision revision)))) + (when (or (typep merged-construct 'TopicC) + (typep merged-construct 'AssociationC) + (typep merged-construct 'TopicMapC)) + (add-to-version-history merged-construct :start-revision revision)) + merged-construct))))) (defgeneric delete-reifier (construct reifier &key revision) @@ -2109,6 +2136,16 @@ (CharacteristicC-p class-symbol)))) +(defgeneric initialize-typable (construct instance-of &key start-revision) + (:documentation "Adds the passed instance-of to the given construct.") + (:method ((construct TypableC) instance-of + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision) (type (or null TopicC) instance-of)) + (when instance-of + (add-type construct instance-of :revision start-revision)) + construct)) + + (defgeneric equivalent-typable-construct (construct instance-of &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. @@ -2129,6 +2166,16 @@ (CharacteristicC-p class-symbol)))) +(defgeneric initialize-scopable (construct themes &key start-revision) + (:documentation "Adds all passed themes to the given construct.") + (:method ((construct ScopableC) (themes list) + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision)) + (dolist (theme themes) + (add-theme construct theme :revision start-revision)) + construct)) + + (defgeneric equivalent-scopable-construct (construct themes &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. the scopable constructs have to own the same themes.") @@ -2324,114 +2371,189 @@ history accordingly. Returns the object in question. Methods use specific keyword arguments for their purpose." (declare (symbol class-symbol)) - (let ((start-revision (getf args :start-revision)) - (uri (getf args :uri)) - (xtm-id (getf args :xtm-id)) - (identified-construct (getf args :identified-construct)) - (charvalue (getf args :charvalue)) - (datatype (getf args :datatype)) - (parent-construct (getf args :parent-construct)) - (themes (getf args :themes)) - (variants (getf args :variants)) - (instance-of (getf args :instance-of)) - (reifier-topic (getf args :reifier)) - (item-identifiers (getf args :item-identifiers))) - (let ((construct - (cond - ((PointerC-p class-symbol) - (make-pointer class-symbol uri :start-revision start-revision - :xtm-id xtm-id - :identified-construct identified-construct)) - ((CharacteristicC-p class-symbol) - (make-characteristic class-symbol charvalue - :start-revision start-revision - :datatype datatype :themes themes - :instance-of instance-of :variants variants - :parent-construct parent-construct))))) - - (when (typep construct 'ReifiableConstructC) - (when reifier-topic - (add-reifier construct reifier-topic :revision start-revision)) - (dolist (ii item-identifiers) - (add-item-identifier construct ii :revision start-revision))) - construct))) + (let ((construct + (cond + ((PointerC-p class-symbol) + (make-pointer class-symbol (getf args :uri) args)) + ((CharacteristicC-p class-symbol) + (make-characteristic class-symbol (getf args :charvalue) args)) + ((TopicC-p class-symbol) + (make-topic args))))) + construct)) -(defun make-characteristic (class-symbol charvalue - &key (start-revision *TM-REVISION*) - (datatype *xml-string*) (themes nil) - (instance-of nil) (variants nil) - (parent-construct nil)) - "Returns a characteristic object with the passed parameters. - If an equivalent construct has already existed this one is returned. - To check if there is existing an equivalent construct the parameter - parent-construct must be set." - (declare (symbol class-symbol) (string charvalue) (integer start-revision) - (list themes variants) - (type (or null string) datatype) - (type (or null TopicC) instance-of) - (type (or null TopicC NameC) parent-construct)) - (let ((characteristic - (let ((existing-characteristic - (when parent-construct +(defun merge-all-constructs(constructs-to-be-merged) + "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))))) + + +(defun make-tm (&rest args) + "Returns a topic map object. If the topic map has already existed the + existing one is returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((item-identifiers (getf (first args) :item-identifiers)) + (reifier (getf (first args) :reifier)) + (topics (getf (first args) :topics)) + (assocs (getf (first args) :associations)) + (start-revision (getf (first args) :start-revision))) + (let ((tm + (let ((existing-tms + (remove-if + #'null + (map 'list #'(lambda(existing-tm) + (when (equivalent-construct + existing-tm + :item-identifiers item-identifiers + :reifier reifier) + existing-tm)) + (elephant:get-instances-by-class 'TopicMapC))))) + (cond ((and existing-tms (> (length existing-tms) 1)) + (merge-all-constructs existing-tms)) + (existing-tms + (first existing-tms)) + (t + (make-instance 'TopicMapC)))))) + (dolist (top-or-assoc (union topics assocs)) + (add-to-tm tm top-or-assoc)) + (add-to-version-history tm :start-revision start-revision) + tm))) + + +(defun make-topic (&rest args) + "Returns a topic object. If the topic has already existed the existing one is + returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((start-revision (getf (first args) :start-revision)) + (psis (getf (first args) :psis)) + (locators (getf (first args) :locators)) + (item-identifiers (getf (first args) :item-identifiers)) + (topic-identifiers (getf (first args) :topic-identifiers)) + (names (getf (first args) :names)) + (occurrences (getf (first args) :occurrences))) + (let ((topic + (let ((existing-topics (remove-if #'null - (map 'list #'(lambda(existing-characteristic) + (map 'list #'(lambda(existing-topic) (when (equivalent-construct - existing-characteristic + existing-topic :start-revision start-revision - :datatype datatype :themes themes - :instance-of instance-of) - existing-characteristic)) - (get-all-characteristics parent-construct - class-symbol)))))) - (if existing-characteristic - existing-characteristic - (make-instance class-symbol :charvalue charvalue - :datatype datatype))))) - (dolist (theme themes) - (add-theme characteristic theme :revision start-revision)) - (when instance-of - (add-type characteristic instance-of :revision start-revision)) - (dolist (variant variants) - (add-variant characteristic variant :revision start-revision)) - (when parent-construct - (add-parent characteristic parent-construct :revision start-revision)))) + :psis psis :locators locators + :item-identifiers item-identifiers + :topic-identifiers topic-identifiers) + existing-topic)) + (elephant:get-instances-by-class 'TopicC))))) + (cond ((and existing-topics (> (length existing-topics) 1)) + (merge-all-constructs existing-topics)) + (existing-topics + (first existing-topics)) + (t + (make-instance 'TopicC)))))) + (initialize-reifiable topic item-identifiers nil + :start-revision start-revision) + (let ((merged-topic topic)) + (dolist (psi psis) + (setf merged-topic (add-psi merged-topic psi + :revision start-revision))) + (dolist (locator locators) + (setf merged-topic (add-locator merged-topic locator + :revision start-revision))) + (dolist (name names) + (setf merged-topic (add-name topic name :revision start-revision))) + (dolist (occ occurrences) + (add-occurrence merged-topic occ :revision start-revision)) + (add-to-version-history merged-topic :start-revision start-revision) + merged-topic)))) + + +(defun make-characteristic (class-symbol &rest args) + "Returns a characteristic object with the passed parameters. + If an equivalent construct has already existed this one is returned. + To check if there is existing an equivalent construct the parameter + parent-construct must be set. + This function only exists for being used by make-construct!" + (let ((charvalue (getf (first args) :charvalue)) + (start-revision (getf (first args) :start-revision)) + (datatype (getf (first args) :datatype)) + (instance-of (getf (first args) :instance-of)) + (themes (getf (first args) :themes)) + (variants (getf (first args) :variants)) + (reifier (getf (first args) :reifier)) + (parent-construct (getf (first args) :parent-construct)) + (item-identifiers (getf (first args) :item-identifiers))) + (let ((characteristic + (let ((existing-characteristic + (when parent-construct + (remove-if + #'null + (map 'list #'(lambda(existing-characteristic) + (when (equivalent-construct + existing-characteristic + :start-revision start-revision + :datatype datatype :variants variants + :charvalue charvalue :themes themes + :instance-of instance-of) + existing-characteristic)) + (get-all-characteristics parent-construct + class-symbol)))))) + (if existing-characteristic + existing-characteristic + (make-instance class-symbol :charvalue charvalue + :datatype datatype))))) + (let ((merged-characteristic characteristic)) + (setf merged-characteristic + (initialize-reifiable merged-characteristic item-identifiers + reifier :start-revision start-revision)) + (initialize-scopable merged-characteristic themes + :start-revision start-revision) + (initialize-typable merged-characteristic instance-of + :start-revision start-revision) + (initialize-name merged-characteristic variants + :start-revision start-revision) + (when parent-construct + (add-parent merged-characteristic parent-construct + :revision start-revision)) + merged-characteristic)))) -(defun make-pointer (class-symbol uri - &key (start-revision *TM-REVISION*) (xtm-id nil) - (identified-construct nil)) +(defun make-pointer (class-symbol &rest args) "Returns a pointer object with the specified parameters. - If an equivalen construct has already existed this one is returned." - (declare (symbol class-symbol) (string uri) (integer start-revision) - (type (or null string) xtm-id) - (type (or null ReifiableconstructC))) - (let ((identifier - (let ((existing-pointer - (remove-if - #'null - (map 'list - #'(lambda(existing-pointer) - (when (equivalent-construct existing-pointer :uri uri - :xtm-id xtm-id) - existing-pointer)) - (elephant:get-instances-by-value class-symbol 'd::uri uri))))) - (if existing-pointer existing-pointer - (make-instance class-symbol :uri uri :xtm-id xtm-id))))) - (when identified-construct - (cond ((TopicIdentificationC-p class-symbol) - (add-topic-identifier identified-construct identifier - :revision start-revision)) - ((PersistentIdC-p class-symbol) - (add-psi identified-construct identifier :revision start-revision)) - ((ItemIdentifierC-p class-symbol) - (add-item-identifier identified-construct identifier - :revision start-revision)) - ((SubjectLocatorC-p class-symbol) - (add-locator identified-construct identifier - :revision start-revision)))) - identifier)) + If an equivalen construct has already existed this one is returned. + This function only exists for beoing used by make-construct!" + (let ((uri (getf (first args) :uri)) + (xtm-id (getf (first args) :xtm-id)) + (start-revision (getf (first args) :start-revision)) + (identified-construct (getf (first args) :identified-construct))) + (let ((identifier + (let ((existing-pointer + (remove-if + #'null + (map 'list + #'(lambda(existing-pointer) + (when (equivalent-construct existing-pointer uri + xtm-id) + existing-pointer)) + (elephant:get-instances-by-value class-symbol 'd::uri uri))))) + (if existing-pointer existing-pointer + (make-instance class-symbol :uri uri :xtm-id xtm-id))))) + (when identified-construct + (cond ((TopicIdentificationC-p class-symbol) + (add-topic-identifier identified-construct identifier + :revision start-revision)) + ((PersistentIdC-p class-symbol) + (add-psi identified-construct identifier :revision start-revision)) + ((ItemIdentifierC-p class-symbol) + (add-item-identifier identified-construct identifier + :revision start-revision)) + ((SubjectLocatorC-p class-symbol) + (add-locator identified-construct identifier + :revision start-revision)))) + identifier))) Modified: branches/new-datamodel/src/rest_interface/rest-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/rest-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/rest-interface.lisp Sat Mar 20 16:33:55 2010 @@ -71,8 +71,9 @@ (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (setf atom:*base-url* (format nil "http://~a:~a" host-name port)) - (elephant:open-store - (xml-importer:get-store-spec repository-path)) + (unless elephant:*store-controller* + (elephant:open-store + (xml-importer:get-store-spec repository-path))) (load conffile) (publish-feed atom:*tm-feed*) (set-up-json-interface) Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp Sat Mar 20 16:33:55 2010 @@ -226,8 +226,8 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (with-writer-lock - (create-latest-fragment-of-topic identifier)))) + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock (to-json-string fragment)) @@ -251,8 +251,8 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (with-writer-lock - (create-latest-fragment-of-topic identifier)))) + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock (rdf-exporter:to-rdf-string fragment)) 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 Sat Mar 20 16:33:55 2010 @@ -1375,10 +1375,6 @@ (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) (revision-0-5 50) (version-1 100)) (setf *TM-REVISION* version-1) @@ -1403,13 +1399,7 @@ :instance-of type-1 :themes (list scope-1 scope-2))) (is-false (d::equivalent-construct occ-1 :charvalue "occ-2" :datatype constants:*xml-string* - :instance-of type-1 :themes (list scope-2 scope-1))) - (add-item-identifier occ-1 ii-1) - (is-true (d::equivalent-construct occ-1 :item-identifiers (list ii-1))) - (is-false (d::equivalent-construct occ-1 :item-identifiers (list ii-2))) - (add-reifier occ-1 reifier-1) - (is-true (d::equivalent-construct occ-1 :reifier reifier-1)) - (is-false (d::equivalent-construct occ-1 :reifier reifier-2))))) + :instance-of type-1 :themes (list scope-2 scope-1)))))) (test test-equivalent-NameC () @@ -1421,10 +1411,6 @@ (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) (revision-0-5 50) (version-1 100)) (setf *TM-REVISION* version-1) @@ -1446,13 +1432,7 @@ :themes (list scope-3 scope-2))) (is-false (d::equivalent-construct nam-1 :charvalue "nam-2" :instance-of type-1 - :themes (list scope-2 scope-1))) - (add-item-identifier nam-1 ii-1) - (is-true (d::equivalent-construct nam-1 :item-identifiers (list ii-1))) - (is-false (d::equivalent-construct nam-1 :item-identifiers (list ii-2))) - (add-reifier nam-1 reifier-1) - (is-true (d::equivalent-construct nam-1 :reifier reifier-1)) - (is-false (d::equivalent-construct nam-1 :reifier reifier-2))))) + :themes (list scope-2 scope-1)))))) (test test-equivalent-VariantC () @@ -1462,10 +1442,6 @@ (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) (revision-0-5 50) (version-1 100)) (setf *TM-REVISION* version-1) @@ -1486,13 +1462,7 @@ :themes (list scope-1 scope-2))) (is-false (d::equivalent-construct var-1 :charvalue "var-2" :datatype constants:*xml-string* - :themes (list scope-2 scope-1))) - (add-item-identifier var-1 ii-1) - (is-true (d::equivalent-construct var-1 :item-identifiers (list ii-1))) - (is-false (d::equivalent-construct var-1 :item-identifiers (list ii-2))) - (add-reifier var-1 reifier-1) - (is-true (d::equivalent-construct var-1 :reifier reifier-1)) - (is-false (d::equivalent-construct var-1 :reifier reifier-2))))) + :themes (list scope-2 scope-1)))))) (test test-equivalent-RoleC () @@ -1503,55 +1473,28 @@ (type-2 (make-instance 'd:TopicC)) (player-1 (make-instance 'd:TopicC)) (player-2 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) - (ii-3 (make-instance 'd:ItemIdentifierC :uri "ii-3")) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) (revision-1 100) (revision-2 200)) (setf *TM-REVISION* revision-1) (add-type role-1 type-1) (add-player role-1 player-1) - (add-item-identifier role-1 ii-1) - (add-item-identifier role-1 ii-2) - (add-reifier role-1 reifier-1) (is-true (d::equivalent-construct role-1 :player player-1 :instance-of type-1)) - (is-true (d::equivalent-construct role-1 - :item-identifiers (list ii-1 ii-3))) - (is-true (d::equivalent-construct role-1 :reifier reifier-1)) (is-false (d::equivalent-construct role-1 :player player-2 :instance-of type-1)) (is-false (d::equivalent-construct role-1 :player player-1 :instance-of type-2)) - (is-false (d::equivalent-construct role-1 - :item-identifiers (list ii-3))) - (is-false (d::equivalent-construct role-1 :reifier reifier-2)) (setf *TM-REVISION* revision-2) - (delete-item-identifier role-1 ii-1 :revision revision-2) (delete-player role-1 player-1 :revision revision-2) (add-player role-1 player-2) (delete-type role-1 type-1 :revision revision-2) (add-type role-1 type-2) - (delete-reifier role-1 reifier-1 :revision revision-2) - (add-reifier role-1 reifier-2) (is-true (d::equivalent-construct role-1 :player player-2 :instance-of type-2)) - (is-true (d::equivalent-construct role-1 - :item-identifiers (list ii-2))) - (is-true (d::equivalent-construct role-1 :reifier reifier-2)) (is-false (d::equivalent-construct role-1 :player player-1 :instance-of type-2)) (is-false (d::equivalent-construct role-1 :player player-2 - :instance-of type-1)) - (is-false (d::equivalent-construct role-1 - :item-identifiers (list ii-1))) - (is-false (d::equivalent-construct role-1 :reifier reifier-1)) - (is-true (d::equivalent-construct role-1 :start-revision revision-1 - :item-identifiers (list ii-1))) - (is-true (d::equivalent-construct role-1 :reifier reifier-1 - :start-revision revision-1))))) + :instance-of type-1))))) (test test-equivalent-AssociationC () @@ -1566,10 +1509,6 @@ (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) (revision-1 100)) (setf *TM-REVISION* revision-1) (d:add-role assoc-1 role-1) @@ -1577,14 +1516,9 @@ (d:add-type assoc-1 type-1) (d:add-theme assoc-1 scope-1) (d:add-theme assoc-1 scope-2) - (d:add-item-identifier assoc-1 ii-1) - (d:add-reifier assoc-1 reifier-1) (is-true (d::equivalent-construct assoc-1 :roles (list role-1 role-2) :instance-of type-1 :themes (list scope-1 scope-2))) - (is-true (d::equivalent-construct assoc-1 - :item-identifiers (list ii-1 ii-2))) - (is-true (d::equivalent-construct assoc-1 :reifier reifier-1)) (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))) @@ -1593,9 +1527,7 @@ :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))) - (is-false (d::equivalent-construct assoc-1 :item-identifiers (list ii-2))) - (is-false (d::equivalent-construct assoc-1 :reifeir reifier-2))))) + :themes (list scope-1 scope-3 scope-2)))))) (test test-equivalent-TopicC () @@ -1608,11 +1540,16 @@ (sl-2 (make-instance 'd:SubjectLocatorC :uri "sl-2")) (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1")) (psi-2 (make-instance 'd:PersistentIdC :uri "psi-2")) + (tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-id-1")) + (tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2" + :xtm-id "xtm-id-2")) (revision-1 100)) (setf *TM-REVISION* revision-1) (d:add-item-identifier top-1 ii-1) (d:add-locator top-1 sl-1) (d:add-psi top-1 psi-1) + (d:add-topic-identifier top-1 tid-1) (is-true (d::equivalent-construct top-1 :item-identifiers (list ii-1 ii-2))) (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2) @@ -1620,6 +1557,8 @@ :item-identifiers (list ii-1 ii-2))) (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2))) (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2))) + (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1))) + (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2))) (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2) :psis (list psi-2) :locators (list sl-2)))))) Modified: branches/new-datamodel/src/xml/rdf/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/importer.lisp (original) +++ branches/new-datamodel/src/xml/rdf/importer.lisp Sat Mar 20 16:33:55 2010 @@ -20,9 +20,9 @@ (xml-importer:init-isidorus) (init-rdf-module) (rdf-importer rdf-xml-path repository-path :tm-id tm-id - :document-id document-id) - (when elephant:*store-controller* - (elephant:close-store))) + :document-id document-id)) +; (when elephant:*store-controller* +; (elephant:close-store))) (defun rdf-importer (rdf-xml-path repository-path @@ -46,7 +46,7 @@ (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" (length (elephant:get-instances-by-class 'TopicC)) (length (elephant:get-instances-by-class 'AssociationC))) - (elephant:close-store) +; (elephant:close-store) (setf *_n-map* nil))) Modified: branches/new-datamodel/src/xml/xtm/setup.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/setup.lisp (original) +++ branches/new-datamodel/src/xml/xtm/setup.lisp Sat Mar 20 16:33:55 2010 @@ -50,6 +50,6 @@ (elephant:open-store (get-store-spec repository-path))) (init-isidorus) - (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format) - (when elephant:*store-controller* - (elephant:close-store))) \ No newline at end of file + (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format)) +; (when elephant:*store-controller* +; (elephant:close-store))) \ No newline at end of file

1 0

[isidorus-cvs] r233 - branches/new-datamodel/src/model
by Lukas Giessmann 18 Mar '10

18 Mar '10

Author: lgiessmann Date: Thu Mar 18 08:50:36 2010 New Revision: 233 Log: new-datamodel: added the handling of "ReifiableConstructC" to "make-construct" Modified: branches/new-datamodel/src/model/datamodel.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 Mar 18 08:50:36 2010 @@ -122,11 +122,9 @@ -;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier, +;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier +;; (can merge the parent construct and the parent's parent construct), ;; add-psi, add-locator - -;;TODO: all add-<construct> methods hve to add an version info to the -;; owner-construct ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -2329,14 +2327,33 @@ (let ((start-revision (getf args :start-revision)) (uri (getf args :uri)) (xtm-id (getf args :xtm-id)) - (identified-construct (getf args :identified-construct))) + (identified-construct (getf args :identified-construct)) + (charvalue (getf args :charvalue)) + (datatype (getf args :datatype)) + (parent-construct (getf args :parent-construct)) + (themes (getf args :themes)) + (variants (getf args :variants)) + (instance-of (getf args :instance-of)) + (reifier-topic (getf args :reifier)) + (item-identifiers (getf args :item-identifiers))) (let ((construct (cond ((PointerC-p class-symbol) (make-pointer class-symbol uri :start-revision start-revision :xtm-id xtm-id - :identified-construct identified-construct))))) - + :identified-construct identified-construct)) + ((CharacteristicC-p class-symbol) + (make-characteristic class-symbol charvalue + :start-revision start-revision + :datatype datatype :themes themes + :instance-of instance-of :variants variants + :parent-construct parent-construct))))) + + (when (typep construct 'ReifiableConstructC) + (when reifier-topic + (add-reifier construct reifier-topic :revision start-revision)) + (dolist (ii item-identifiers) + (add-item-identifier construct ii :revision start-revision))) construct)))

1 0

[isidorus-cvs] r232 - branches/new-datamodel/src/model
by Lukas Giessmann 18 Mar '10

18 Mar '10

Author: lgiessmann Date: Thu Mar 18 08:39:15 2010 New Revision: 232 Log: new-datamodel: added the helper function "make-characteristic" for "make-construct"; fixed a bug in all add-<construct> generics that are defined for "VersionedConstruct"s, so currently adding a charactersistic or pointer calls add-to-version-history with the given revision for the called parent-construct and signals that the parent-construct was changed in the given revision. Modified: branches/new-datamodel/src/model/datamodel.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 Mar 18 08:39:15 2010 @@ -125,7 +125,8 @@ ;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier, ;; add-psi, add-locator - +;;TODO: all add-<construct> methods hve to add an version info to the +;; owner-construct ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -662,6 +663,11 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric get-all-characteristics (parent-construct characteristic-symbol) + (:documentation "Returns all characterisitcs of the passed type the parent + construct was ever associated with.")) + + (defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) (:documentation "Returns t if the passed construct is equivalent to the passed @@ -810,6 +816,14 @@ ;;; TopicMapconstructC +(defmethod get-all-characteristics ((parent-construct TopicC) + (characteristic-symbol symbol)) + (cond ((OccurrenceC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'occurrences))) + ((NameC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'names))))) + + (defgeneric TopicMapConstructC-p (class-symbol) (:documentation "Returns t if the passed class is equal to TopicMapConstructC or one of its subtypes.") @@ -1091,6 +1105,8 @@ :parent-construct construct :identifier topic-identifier))) (add-to-version-history assoc :start-revision revision)))) + (when (typep construct 'TopicC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -1144,6 +1160,7 @@ :parent-construct construct :identifier psi))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct))) @@ -1197,6 +1214,7 @@ :parent-construct construct :identifier locator))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct))) @@ -1247,6 +1265,7 @@ :parent-construct construct :characteristic name))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct)) @@ -1296,6 +1315,7 @@ :parent-construct construct :characteristic occurrence))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct)) @@ -1600,6 +1620,12 @@ ;;; NameC +(defmethod get-all-characteristics ((parent-construct NameC) + (characteristic-symbol symbol)) + (when (VariantC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'variants)))) + + (defgeneric NameC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to Name.") (:method ((class-symbol symbol)) @@ -1747,6 +1773,7 @@ :role role :parent-construct construct))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct)) @@ -1842,6 +1869,7 @@ :role construct :parent-construct parent-construct))) (add-to-version-history assoc :start-revision revision))))) + (add-to-version-history parent-construct :start-revision revision) construct) @@ -1999,6 +2027,10 @@ :parent-construct construct :identifier item-identifier))) (add-to-version-history assoc :start-revision revision)))) + (when (or (typep construct 'TopicC) + (typep construct 'AssociationC) + (typep construct 'TopicMapC)) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2049,6 +2081,10 @@ :reifiable-construct construct :reifier-topic merged-reifier-topic))) (add-to-version-history assoc :start-revision revision)))) + (when (or (typep construct 'TopicC) + (typep construct 'AssociationC) + (typep construct 'TopicMapC)) + (add-to-version-history construct :start-revision revision)) construct)))) @@ -2137,6 +2173,8 @@ :theme-topic theme-topic :scopable-construct construct))) (add-to-version-history assoc :start-revision revision)))) + (when (typep construct 'AssociationC) + (add-to-version-history construct :start-revision revision)) construct)) @@ -2207,6 +2245,8 @@ :type-topic type-topic :typable-construct construct))) (add-to-version-history assoc :start-revision revision))))) + (when (typep construct 'AssociationC) + (add-to-version-history construct :start-revision revision)) construct)) @@ -2300,11 +2340,53 @@ construct))) +(defun make-characteristic (class-symbol charvalue + &key (start-revision *TM-REVISION*) + (datatype *xml-string*) (themes nil) + (instance-of nil) (variants nil) + (parent-construct nil)) + "Returns a characteristic object with the passed parameters. + If an equivalent construct has already existed this one is returned. + To check if there is existing an equivalent construct the parameter + parent-construct must be set." + (declare (symbol class-symbol) (string charvalue) (integer start-revision) + (list themes variants) + (type (or null string) datatype) + (type (or null TopicC) instance-of) + (type (or null TopicC NameC) parent-construct)) + (let ((characteristic + (let ((existing-characteristic + (when parent-construct + (remove-if + #'null + (map 'list #'(lambda(existing-characteristic) + (when (equivalent-construct + existing-characteristic + :start-revision start-revision + :datatype datatype :themes themes + :instance-of instance-of) + existing-characteristic)) + (get-all-characteristics parent-construct + class-symbol)))))) + (if existing-characteristic + existing-characteristic + (make-instance class-symbol :charvalue charvalue + :datatype datatype))))) + (dolist (theme themes) + (add-theme characteristic theme :revision start-revision)) + (when instance-of + (add-type characteristic instance-of :revision start-revision)) + (dolist (variant variants) + (add-variant characteristic variant :revision start-revision)) + (when parent-construct + (add-parent characteristic parent-construct :revision start-revision)))) + (defun make-pointer (class-symbol uri &key (start-revision *TM-REVISION*) (xtm-id nil) (identified-construct nil)) - "Returns a pointer object with the specified parameters." + "Returns a pointer object with the specified parameters. + If an equivalen construct has already existed this one is returned." (declare (symbol class-symbol) (string uri) (integer start-revision) (type (or null string) xtm-id) (type (or null ReifiableconstructC)))

1 0

[isidorus-cvs] r231 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 18 Mar '10

18 Mar '10

Author: lgiessmann Date: Thu Mar 18 07:40:32 2010 New Revision: 231 Log: new-datamodel: added the helper function "make-pointer" for "make-construct"; added the generics <class>-p to all class-symbols and a unit-test fort these methods. 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 Mar 18 07:40:32 2010 @@ -92,6 +92,26 @@ :get-item-by-locator :string-integer-p :with-revision + :PointerC-p + :IdentifierC-p + :SubjectLocatorC-p + :PersistentIdC-p + :ItemIdentifierC-p + :TopicIdentificationC-p + :CharacteristicC-p + :OccurrenceC-p + :NameC-p + :VariantC-p + :ScopableC-p + :TypableC-p + :TopicC-p + :AssociationC-p + :RoleC-p + :TopicMapC-p + :ReifiableConstructC-p + :TopicMapConstructC-p + :VersionedConstructC-p + :make-construct ;;globals :*TM-REVISION* @@ -100,6 +120,12 @@ (in-package :datamodel) + + +;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier, +;; add-psi, add-locator + + ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -108,8 +134,6 @@ ;; and a merge should be done ;;TODO: use some exceptions --> more than one type, ;; identifier, not-mergable merges, missing-init-args... -;;TODO: implement make-construct -> symbol -;; replace the latest make-construct-method ;;TODO: implement merge-construct -> ReifiableConstructC -> ... ;; the method should merge two constructs that are inherited from ;; ReifiableConstructC @@ -583,17 +607,6 @@ (error () nil)))) -(defun make-construct (class-symbol &key start-revision &allow-other-keys) - "Creates a new topic map construct if necessary or - retrieves an equivalent one if available and updates the revision - history accordingly. Returns the object in question. Methods use - specific keyword arguments for their purpose." - (or class-symbol start-revision) - ;TODO: implement - ) - - - (defun delete-1-n-association(instance slot-symbol) (when (slot-p instance slot-symbol) (remove-association @@ -691,6 +704,16 @@ ;;; VersionedConstructC +(defgeneric VersionedConstructC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to VersionedConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'VersionedconstructC) + (TopicC-p class-symbol) + (TopicMapC-p class-symbol) + (AssociationC-p class-symbol)))) + + (defmethod delete-construct :before ((construct VersionedConstructC)) (dolist (version-info (versions construct)) (delete-construct version-info))) @@ -786,7 +809,29 @@ (setf (end-revision last-version) revision))))) +;;; TopicMapconstructC +(defgeneric TopicMapConstructC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to TopicMapConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'TopicMapConstructC) + (ReifiableConstructC-p class-symbol) + (PointerC-p class-symbol)))) + + ;;; PointerC +(defgeneric PointerC-p (class-symbol) + (:documentation "Returns t if the passed symbol corresponds to the class + PointerC or one of its subclasses.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'PointerC) + (IdentifierC-p class-symbol) + (TopicIdentificationC-p class-symbol) + (PersistentIdC-p class-symbol) + (ItemIdentifierC-p class-symbol) + (SubjectLocatorC-p class-symbol)))) + + (defmethod equivalent-construct ((construct PointerC) &key start-revision (uri "")) "All Pointers are equal if they have the same URI value." @@ -817,6 +862,13 @@ ;;; TopicIdentificationC +(defgeneric TopicIdentificationC-p (class-symbol) + (:documentation "Returns t if the passed class symbol is equal + to TopicIdentificationC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'TopicIdentificationC))) + + (defmethod equivalent-construct ((construct TopicIdentificationC) &key start-revision (uri "") (xtm-id "")) "TopicIdentifiers are equal if teh URI and XTM-ID values are equal." @@ -828,6 +880,37 @@ (string= (xtm-id construct) xtm-id)))) +;;; IdentifierC +(defgeneric IdentifierC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to IdentifierC + or one of its sybtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'IdentifierC) + (PersistentIdC-p class-symbol) + (SubjectLocatorC-p class-symbol) + (ItemIdentifierC-p class-symbol)))) + + +;;; PersistentIdC +(defgeneric PersistentIdC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to PersistentIdC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'PersistentIdC))) + + +;;; ItemIdentifierC +(defgeneric ItemIdentifierC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to ItemIdentifierC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'ItemIdentifierC))) + +;;; SubjectLocatorC +(defgeneric SubjectLocatorC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to SubjectLocatorC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'SubjectLocatorC))) + + ;;; PointerAssociationC (defmethod delete-construct :before ((construct PointerAssociationC)) (delete-1-n-association construct 'identifier)) @@ -904,6 +987,12 @@ ;;; TopicC +(defgeneric TopicC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to TopicC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'TopicC))) + + (defmethod equivalent-construct ((construct TopicC) &key (start-revision 0) (psis nil) (locators nil) (item-identifiers nil)) @@ -1362,6 +1451,16 @@ ;;; CharacteristicC +(defgeneric CharacteristicC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to CharacteristicC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'CharacteristicC) + (OccurrenceC-p class-symbol) + (NameC-p class-symbol) + (VariantC-p class-symbol)))) + + (defmethod equivalent-construct ((construct CharacteristicC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") @@ -1454,6 +1553,12 @@ ;;; OccurrenceC +(defgeneric OccurrenceC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to OccurrenceC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'OccurrenceC))) + + (defmethod equivalent-construct ((construct OccurrenceC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") @@ -1472,6 +1577,12 @@ ;;; VariantC +(defgeneric VariantC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to VariantC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'VariantC))) + + (defmethod equivalent-construct ((construct VariantC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") @@ -1489,6 +1600,12 @@ ;;; NameC +(defgeneric NameC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to Name.") + (:method ((class-symbol symbol)) + (eql class-symbol 'NameC))) + + (defmethod equivalent-construct ((construct NameC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") @@ -1561,6 +1678,12 @@ ;;; AssociationC +(defgeneric AssociationC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to AssociationC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'AssociationC))) + + (defmethod equivalent-construct ((construct AssociationC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (roles nil) @@ -1645,6 +1768,12 @@ ;;; RoleC +(defgeneric RoleC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to RoleC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'RoleC))) + + (defmethod equivalent-construct ((construct RoleC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (player nil) @@ -1782,6 +1911,18 @@ ;;; ReifiableConstructC +(defgeneric ReifiableConstructC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to ReifiableConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'ReifiableconstructC) + (TopicMapC-p class-symbol) + (TopicC-p class-symbol) + (AssociationC-p class-symbol) + (RoleC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + (defgeneric equivalent-reifiable-construct (construct reifier item-identifiers &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e @@ -1924,6 +2065,16 @@ construct))) ;;; TypableC +(defgeneric TypableC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to TypableC or + one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'TypableC) + (AssociationC-p class-symbol) + (RoleC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + (defgeneric equivalent-typable-construct (construct instance-of &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. @@ -1935,6 +2086,15 @@ ;;; ScopableC +(defgeneric ScopableC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to ScopableC or + one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'ScopableC) + (AssociationC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + (defgeneric equivalent-scopable-construct (construct themes &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. the scopable constructs have to own the same themes.") @@ -2065,6 +2225,12 @@ ;;; TopicMapC +(defgeneric TopicMapC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to TopicMapC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'TopicMapC))) + + (defmethod equivalent-construct ((construct TopicMapC) &key (start-revision 0) (reifier nil) (item-identifiers nil)) @@ -2113,9 +2279,83 @@ (remove-association construct 'associations construct-to-delete)) +;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun make-construct (class-symbol &rest args) + "Creates a new topic map construct if necessary or + retrieves an equivalent one if available and updates the revision + history accordingly. Returns the object in question. Methods use + specific keyword arguments for their purpose." + (declare (symbol class-symbol)) + (let ((start-revision (getf args :start-revision)) + (uri (getf args :uri)) + (xtm-id (getf args :xtm-id)) + (identified-construct (getf args :identified-construct))) + (let ((construct + (cond + ((PointerC-p class-symbol) + (make-pointer class-symbol uri :start-revision start-revision + :xtm-id xtm-id + :identified-construct identified-construct))))) + + construct))) + + + +(defun make-pointer (class-symbol uri + &key (start-revision *TM-REVISION*) (xtm-id nil) + (identified-construct nil)) + "Returns a pointer object with the specified parameters." + (declare (symbol class-symbol) (string uri) (integer start-revision) + (type (or null string) xtm-id) + (type (or null ReifiableconstructC))) + (let ((identifier + (let ((existing-pointer + (remove-if + #'null + (map 'list + #'(lambda(existing-pointer) + (when (equivalent-construct existing-pointer :uri uri + :xtm-id xtm-id) + existing-pointer)) + (elephant:get-instances-by-value class-symbol 'd::uri uri))))) + (if existing-pointer existing-pointer + (make-instance class-symbol :uri uri :xtm-id xtm-id))))) + (when identified-construct + (cond ((TopicIdentificationC-p class-symbol) + (add-topic-identifier identified-construct identifier + :revision start-revision)) + ((PersistentIdC-p class-symbol) + (add-psi identified-construct identifier :revision start-revision)) + ((ItemIdentifierC-p class-symbol) + (add-item-identifier identified-construct identifier + :revision start-revision)) + ((SubjectLocatorC-p class-symbol) + (add-locator identified-construct identifier + :revision start-revision)))) + identifier)) + + + + + + + + + + + + + + + + + + + + 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 Mar 18 07:40:32 2010 @@ -57,7 +57,8 @@ :test-equivalent-RoleC :test-equivalent-AssociationC :test-equivalent-TopicC - :test-equivalent-TopicMapC)) + :test-equivalent-TopicMapC + :test-class-p)) ;;TODO: test merge-constructs when merging was caused by an item-dentifier, @@ -1643,6 +1644,61 @@ (is-false (d::equivalent-construct tm-1 :reifier reifier-2))))) +(test test-class-p () + "Tests the functions <class>-p." + (let ((identifier (list 'd::IdentifierC 'd::ItemIdentifierC 'd:PersistentIdC + 'd:SubjectLocatorC)) + (topic-identifier (list 'd::TopicIdentificationC)) + (characteristic (list 'd::CharacteristicC 'd:OccurrenceC 'd:NameC + 'd:VariantC)) + (topic (list 'd:TopicC)) + (assoc (list 'd:AssociationC)) + (role (list 'd:AssociationC)) + (tm (list 'd:TopicMapC))) + (let ((pointer (append identifier topic-identifier)) + (reifiable (append topic assoc role tm characteristic)) + (typable (append characteristic assoc role)) + (scopable (append characteristic assoc))) + (dolist (class pointer) + (is-true (d:PointerC-p class))) + (dolist (class identifier) + (is-true (d:IdentifierC-p class))) + (dolist (class topic-identifier) + (is-true (d:TopicIdentificationC-p class))) + (is-true (d:PersistentIdC-p 'd:PersistentIdC)) + (is-true (d:SubjectLocatorC-p 'd:SubjectLocatorC)) + (is-true (d:ItemIdentifierC-p 'd:ItemIdentifierC)) + (dolist (class characteristic) + (is-true (d:CharacteristicC-p class))) + (is-true (d:OccurrenceC-p 'd:OccurrenceC)) + (is-true (d:VariantC-p 'd:VariantC)) + (is-true (d:NameC-p 'd:NameC)) + (is-true (d:RoleC-p 'd:RoleC)) + (is-true (d:AssociationC-p 'd:AssociationC)) + (is-true (d:TopicC-p 'd:TopicC)) + (is-true (d:TopicMapC-p 'd:TopicMapC)) + (dolist (class reifiable) + (is-true (d:ReifiableconstructC-p class))) + (dolist (class scopable) + (is-true (d:ScopableC-p class))) + (dolist (class typable) + (is-true (d:TypableC-p class))) + (dolist (class (append reifiable pointer)) + (is-true (d:TopicMapConstructC-p class))) + (dolist (class (append topic tm assoc)) + (is-true (d:VersionedConstructC-p class))) + (dolist (class identifier) + (is-false (d:TopicIdentificationC-p class))) + (dolist (class topic-identifier) + (is-false (d:IdentifierC-p class))) + (dolist (class characteristic) + (is-false (d:PointerC-p class)))))) + + + + + + (defun run-datamodel-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) @@ -1683,4 +1739,5 @@ (it.bese.fiveam:run! 'test-equivalent-AssociationC) (it.bese.fiveam:run! 'test-equivalent-TopicC) (it.bese.fiveam:run! 'test-equivalent-TopicMapC) + (it.bese.fiveam:run! 'test-class-p) ) \ No newline at end of file

1 0

[isidorus-cvs] r230 - branches/new-datamodel/src/threading trunk/src/threading
by Lukas Giessmann 17 Mar '10

17 Mar '10

Author: lgiessmann Date: Wed Mar 17 17:35:49 2010 New Revision: 230 Log: fixed ticket #68 --> http://trac.common-lisp.net/isidorus/ticket/68 Modified: branches/new-datamodel/src/threading/reader-writer.lisp trunk/src/threading/reader-writer.lisp Modified: branches/new-datamodel/src/threading/reader-writer.lisp ============================================================================== --- branches/new-datamodel/src/threading/reader-writer.lisp (original) +++ branches/new-datamodel/src/threading/reader-writer.lisp Wed Mar 17 17:35:49 2010 @@ -65,5 +65,5 @@ (do ((remaining-readers (current-readers) (current-readers))) ((null remaining-readers)) - (sleep 0.5)) + (sleep 0.05)) ,@body)) \ No newline at end of file Modified: trunk/src/threading/reader-writer.lisp ============================================================================== --- trunk/src/threading/reader-writer.lisp (original) +++ trunk/src/threading/reader-writer.lisp Wed Mar 17 17:35:49 2010 @@ -65,5 +65,5 @@ (do ((remaining-readers (current-readers) (current-readers))) ((null remaining-readers)) - (sleep 0.5)) + (sleep 0.05)) ,@body)) \ No newline at end of file

1 0