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

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

27 Feb '10

Author: lgiessmann Date: Sat Feb 27 06:37:56 2010 New Revision: 217 Log: new-datamodel: added some unit-tests for the class TopicMapC; added the generics add-to-tm and delete-from-tm. Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Sat Feb 27 06:37:56 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sat Feb 27 06:37:56 2010 @@ -25,7 +25,7 @@ :TopicIdentificationC :TopicC - ;;methods and functions + ;;methods, functions and macros :xtm-id :uri :identified-construct @@ -56,6 +56,8 @@ :delete-role :associations :topics + :add-to-tm + :delete-from-tm :psis :add-psi :delete-psi @@ -86,6 +88,7 @@ :get-item-by-item-identifier :get-item-by-locator :string-integer-p + :with-revision ;;globals :*TM-REVISION* @@ -281,11 +284,11 @@ (elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC) - ((topics :accessor topics - :associate (TopicC in-topicmaps) + ((topics :associate (TopicC in-topicmaps) + :many-to-many t :documentation "List of topics that explicitly belong to this TM.") - (associations :accessor associations - :associate (AssociationC in-topicmaps) + (associations :associate (AssociationC in-topicmaps) + :many-to-many t :documentation "List of associations that belong to this TM.")) (:documentation "Represnets a topic map.")) @@ -557,6 +560,12 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro with-revision (revision &rest body) + `(let + ((*TM-REVISION* ,revision)) + ,@body)) + + (defun slot-p (instance slot-symbol) "Returns t if the slot depending on slot-symbol is bound and not nil." (if (slot-boundp instance slot-symbol) @@ -1803,7 +1812,45 @@ construct))) +;;; TopicMapC +(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))) + + +(defgeneric add-to-tm (construct construct-to-add) + (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM.")) + + +(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) + (add-association construct 'topics construct-to-add)) + + +(defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC)) + (add-association construct 'associations construct-to-add)) + + +(defgeneric delete-from-tm (construct construct-to-delete) + (:documentation "Deletes a TM construct (TopicC or AssociationC) from + the TM.")) + + +(defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC)) + (remove-association construct 'topics construct-to-delete)) + +(defmethod delete-from-tm ((construct TopicMapC) + (construct-to-delete AssociationC)) + (remove-association construct 'associations construct-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 Sat Feb 27 06:37:56 2010 @@ -35,7 +35,8 @@ :test-TypableC :test-ScopableC :test-RoleC - :test-player)) + :test-player + :test-TopicMapC)) ;;TODO: test delete-construct @@ -868,10 +869,57 @@ (is (= (length (union (list role-1 role-2) (player-in-roles top-1))) 2)) (is (= (length (slot-value top-1 'd::player-in-roles)) 2))))) + + +(test test-TopicMapC () + "Tests various function of the class TopicMapC." + (with-fixture with-empty-db (*db-dir*) + (let ((tm-1 (make-instance 'TopicMapC)) + (tm-2 (make-instance 'TopicMapC)) + (top-1 (make-instance 'TopicC)) + (assoc-1 (make-instance 'AssociationC)) + (revision-0-5 50) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (is-false (topics tm-1)) + (is-false (in-topicmaps top-1)) + (is-false (in-topicmaps assoc-1)) + (d::add-to-version-history top-1 :start-revision revision-1) + (add-to-tm tm-1 top-1) + (is (= (length (union (list top-1) + (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) + (is (= (length (union (list assoc-1) + (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) + (is (= (length (union (list assoc-1) + (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))))) (defun run-datamodel-tests() + "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) (it.bese.fiveam:run! 'test-ItemIdentifierC) @@ -890,4 +938,4 @@ (it.bese.fiveam:run! 'test-ScopableC) (it.bese.fiveam:run! 'test-RoleC) (it.bese.fiveam:run! 'test-player) -) \ No newline at end of file + (it.bese.fiveam:run! 'test-TopicMapC)) \ No newline at end of file

1 0

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

27 Feb '10

Author: lgiessmann Date: Sat Feb 27 05:43:01 2010 New Revision: 216 Log: new-datamodel: added some unit-tests for the class RoleC --> player handling. 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 Feb 27 05:43:01 2010 @@ -1524,24 +1524,29 @@ (:documentation "Adds a topic as a player to a role in the given revision.") (:method ((construct RoleC) (player-topic TopicC) &key (revision *TM-REVISION*)) - (let ((already-set-player (player construct :revision revision))) - ;;TODO: search a player-assoc for the passed construct that was set in an older version - (cond ((and already-set-player - (eql (first already-set-player) player-topic)) + (let ((already-set-player (player construct :revision revision)) + (same-player-assoc + (loop for player-assoc in (slot-p construct 'player) + when (eql (player-topic player-assoc) player-topic) + return player-assoc))) + (when (and already-set-player + (not (eql already-set-player player-topic))) + (error "From add-player(): ~a can't be palyed by ~a since it is played by ~a" + construct player-topic already-set-player)) + (cond (already-set-player (let ((player-assoc (loop for player-assoc in (slot-p construct 'player) when (eql player-topic (player-topic player-assoc)) return player-assoc))) (add-to-version-history player-assoc :start-revision revision))) - ((not already-set-player) + (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))) - (t - (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a" - player-topic construct already-set-player))) - construct))) + (add-to-version-history assoc :start-revision revision))))) + construct)) (defgeneric delete-player (construct player-topic &key 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 Sat Feb 27 05:43:01 2010 @@ -34,7 +34,8 @@ :test-NameC :test-TypableC :test-ScopableC - :test-RoleC)) + :test-RoleC + :test-player)) ;;TODO: test delete-construct @@ -828,6 +829,45 @@ (is (= (length (slot-value assoc-2 'roles)) 2)) (is (= (length (slot-value role-1 'parent)) 2)) (is (= (length (slot-value role-2 'parent)) 2))))) + + +(test test-player () + "Tests various functions of the topics that are used as player in roles." + (with-fixture with-empty-db (*db-dir*) + (let ((role-1 (make-instance 'RoleC)) + (role-2 (make-instance 'RoleC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-0-5 50) + (revision-1 100) + (revision-2 200) + (revision-3 300)) + (setf *TM-REVISION* revision-1) + (is-false (player role-1)) + (add-player role-1 top-1) + (is (eql top-1 (player role-1))) + (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-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)) + (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 (= (length (union (list role-2) + (player-in-roles top-1))) 1)) + (add-player role-1 top-1 :revision revision-3) + (is (eql top-1 (player role-1))) + (is (= (length (union (list role-1 role-2) + (player-in-roles top-1))) 2)) + (is (= (length (slot-value top-1 'd::player-in-roles)) 2))))) @@ -849,4 +889,5 @@ (it.bese.fiveam:run! 'test-TypableC) (it.bese.fiveam:run! 'test-ScopableC) (it.bese.fiveam:run! 'test-RoleC) + (it.bese.fiveam:run! 'test-player) ) \ No newline at end of file

1 0

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

27 Feb '10

Author: lgiessmann Date: Sat Feb 27 05:22:23 2010 New Revision: 215 Log: new-datamodel: added some unit-tests for the class RoleC; fixed a bug in add-parent and add-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 Sat Feb 27 05:22:23 2010 @@ -94,9 +94,6 @@ (in-package :datamodel) -;;TODO: add-type/add-parent/add-<x>-identifier handle situation where -;; new objects hve to be bound in an earlier revision than one -;; where a object is already bound ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -265,7 +262,7 @@ (defpclass AssociationC(ReifiableConstructC ScopableC TypableC VersionedConstructC) - ((roles :associate (RoleAssociationC association) + ((roles :associate (RoleAssociationC parent-construct) :documentation "Contains all association-objects of all roles this association contains.") (in-topicmaps :associate (TopicMapC associations) @@ -1424,8 +1421,7 @@ (:method ((construct AssociationC) (role RoleC) &key (revision *TM-REVISION*)) (let ((all-roles - (map 'list #'role - (remove-if #'marked-as-deleted-p (slot-p construct 'roles))))) + (map 'list #'role (slot-p construct 'roles)))) (if (find role all-roles) (let ((role-assoc (loop for role-assoc in (slot-p construct 'roles) @@ -1435,7 +1431,7 @@ (let ((assoc (make-instance 'RoleAssociationC :role role - :association construct))) + :parent-construct construct))) (add-to-version-history assoc :start-revision revision)))) construct)) @@ -1477,27 +1473,29 @@ (defmethod add-parent ((construct RoleC) (parent-construct AssociationC) &key (revision *TM-REVISION*)) - (let ((already-set-parent - (map 'list #'parent - (filter-slot-value-by-revision construct 'parent - :start-revision revision)))) - (cond ((and already-set-parent - (eql (first already-set-parent) parent-construct)) - (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))) - ((not already-set-parent) - (let ((assoc (make-instance 'RoleAssociationC - :role construct - :parent-construct parent-construct))) - (add-to-version-history assoc :start-revision revision))) - (t - (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a" - parent-construct construct already-set-parent))) - construct)) + (let ((already-set-parent (parent construct :revision revision)) + (same-parent-assoc (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 ((assoc (make-instance 'RoleAssociationC + :role construct + :parent-construct parent-construct))) + (add-to-version-history assoc :start-revision revision))))) + construct) (defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) @@ -1526,10 +1524,7 @@ (:documentation "Adds a topic as a player to a role in the given revision.") (:method ((construct RoleC) (player-topic TopicC) &key (revision *TM-REVISION*)) - (let ((already-set-player - (map 'list #'player-topic - (filter-slot-value-by-revision construct 'player - :start-revision revision)))) + (let ((already-set-player (player construct :revision revision))) ;;TODO: search a player-assoc for the passed construct that was set in an older version (cond ((and already-set-player (eql (first already-set-player) player-topic)) @@ -1763,10 +1758,7 @@ set at the same revision.") (:method ((construct TypableC) (type-topic TopicC) &key (revision *TM-REVISION*)) - (let ((already-set-type - (map 'list #'type-topic - (filter-slot-value-by-revision construct 'instance-of - :start-revision revision))) + (let ((already-set-type (instance-of construct :revision revision)) (same-type-assoc (loop for type-assoc in (slot-p construct 'instance-of) when (eql (type-topic type-assoc) type-topic) 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 Feb 27 05:22:23 2010 @@ -17,6 +17,7 @@ (:import-from :exceptions duplicate-identifier-error) (:export :run-datamodel-tests + :datamodel-test :test-VersionInfoC :test-VersionedConstructC :test-ItemIdentifierC @@ -32,7 +33,8 @@ :test-VariantC :test-NameC :test-TypableC - :test-ScopableC)) + :test-ScopableC + :test-RoleC)) ;;TODO: test delete-construct @@ -776,6 +778,56 @@ (is (= (length (slot-value occ-2 'd::themes)) 1)) (is (= (length (slot-value top-1 'd::used-as-theme)) 1)) (is (= (length (slot-value top-2 'd::used-as-theme)) 2))))) + + +(test test-RoleC () + "Tests various functions of the class RoleC." + (with-fixture with-empty-db (*db-dir*) + (let ((role-1 (make-instance 'RoleC)) + (role-2 (make-instance 'RoleC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (revision-1 100) + (revision-2 200) + (revision-3 300)) + (setf *TM-REVISION* revision-1) + (is-false (roles assoc-1)) + (is-false (parent role-1)) + (add-parent role-1 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 (union (list role-1 role-2) + (roles assoc-1))) 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) + (is-false (parent role-1)) + (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)) + (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)) + (is (= (length (union (list role-1 role-2) + (roles assoc-2))) 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))))) @@ -796,4 +848,5 @@ (it.bese.fiveam:run! 'test-NameC) (it.bese.fiveam:run! 'test-TypableC) (it.bese.fiveam:run! 'test-ScopableC) + (it.bese.fiveam:run! 'test-RoleC) ) \ No newline at end of file

1 0

[isidorus-cvs] r214 - in branches/new-datamodel: docs src/model src/unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 15:22:11 2010 New Revision: 214 Log: new-datamodel: added some unit-tests for the base class ScopableC. Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Fri Feb 26 15:22:11 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Fri Feb 26 15:22:11 2010 @@ -1711,8 +1711,7 @@ (:method ((construct ScopableC) (theme-topic TopicC) &key (revision *TM-REVISION*)) (let ((all-themes - (map 'list #'theme-topic - (remove-if #'marked-as-deleted-p (slot-p construct 'themes))))) + (map 'list #'theme-topic (slot-p construct 'themes)))) (if (find theme-topic all-themes) (let ((theme-assoc (loop for theme-assoc in (slot-p construct 'themes) @@ -1720,7 +1719,7 @@ return theme-assoc))) (add-to-version-history theme-assoc :start-revision revision)) (let ((assoc - (make-instance 'ScopeAssociationCn + (make-instance 'ScopeAssociationC :theme-topic theme-topic :scopable-construct construct))) (add-to-version-history assoc :start-revision 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 Fri Feb 26 15:22:11 2010 @@ -31,7 +31,8 @@ :test-OccurrenceC :test-VariantC :test-NameC - :test-TypableC)) + :test-TypableC + :test-ScopableC)) ;;TODO: test delete-construct @@ -725,6 +726,56 @@ (is (= (length (union (list name-1 name-2) (used-as-type top-1))) 2)) (is (= (length (slot-value top-1 'd::used-as-type)) 2))))) + + +(test test-ScopableC () + "Tests various functions of the base class ScopableC." + (with-fixture with-empty-db (*db-dir*) + (let ((occ-1 (make-instance 'OccurrenceC)) + (occ-2 (make-instance 'OccurrenceC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (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)) + (add-theme occ-1 top-1) + (is (= (length (union (list top-1) + (themes occ-1))) 1)) + (is (= (length (union (list occ-1) + (used-as-theme top-1))) 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-2)) + (add-theme occ-1 top-1 :revision revision-3) + (is (= (length (union (list top-1) + (themes occ-1))) 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)) + (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)) + (add-theme occ-2 top-2 :revision revision-3) + (is (= (length (union (list top-1 top-2) + (themes occ-1))) 2)) + (is (= (length (union (list top-2) + (themes occ-2))) 1)) + (is (= (length (union (list occ-1) + (used-as-theme top-1))) 1)) + (is (= (length (union (list occ-1 occ-2) + (used-as-theme top-2))) 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)) + (is (= (length (slot-value top-2 'd::used-as-theme)) 2))))) @@ -744,4 +795,5 @@ (it.bese.fiveam:run! 'test-VariantC) (it.bese.fiveam:run! 'test-NameC) (it.bese.fiveam:run! 'test-TypableC) + (it.bese.fiveam:run! 'test-ScopableC) ) \ No newline at end of file

1 0

[isidorus-cvs] r213 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 10:50:44 2010 New Revision: 213 Log: new-datamodel: added some unit-tests for the base class TypableC; optimized the function add-type. 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 Fri Feb 26 10:50:44 2010 @@ -94,6 +94,9 @@ (in-package :datamodel) +;;TODO: add-type/add-parent/add-<x>-identifier handle situation where +;; new objects hve to be bound in an earlier revision than one +;; where a object is already bound ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -170,7 +173,7 @@ (defpclass TypableC() - ((instance-of :associate (TypeAssociationC type-topic) + ((instance-of :associate (TypeAssociationC typable-construct) :inherit t :documentation "Contains all association-objects that contain the actual type-topic.")) @@ -1527,6 +1530,7 @@ (map 'list #'player-topic (filter-slot-value-by-revision construct 'player :start-revision revision)))) + ;;TODO: search a player-assoc for the passed construct that was set in an older version (cond ((and already-set-player (eql (first already-set-player) player-topic)) (let ((player-assoc @@ -1763,24 +1767,30 @@ (let ((already-set-type (map 'list #'type-topic (filter-slot-value-by-revision construct 'instance-of - :start-revision revision)))) - (cond ((and already-set-type - (eql (first already-set-type) type-topic)) + :start-revision revision))) + (same-type-assoc + (loop for type-assoc in (slot-p construct 'instance-of) + when (eql (type-topic type-assoc) type-topic) + return type-assoc))) + (when (and already-set-type + (not (eql type-topic already-set-type))) + (error "From add-type(): ~a can't be typed by ~a since it is typed by ~a" + construct type-topic already-set-type)) + (cond (already-set-type (let ((type-assoc (loop for type-assoc in (slot-p construct 'instance-of) when (eql type-topic (type-topic type-assoc)) return type-assoc))) (add-to-version-history type-assoc :start-revision revision))) - ((not already-set-type) + (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))) - (t - (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a" - construct type-topic already-set-type))) - construct))) + (add-to-version-history assoc :start-revision revision))))) + construct)) (defgeneric delete-type (construct type-topic &key 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 Fri Feb 26 10:50:44 2010 @@ -30,7 +30,8 @@ :test-ReifiableConstructC :test-OccurrenceC :test-VariantC - :test-NameC)) + :test-NameC + :test-TypableC)) ;;TODO: test delete-construct @@ -689,6 +690,41 @@ (is-false (parent name-2)) (add-parent name-2 top-1 :revision revision-8) (is (eql top-1 (parent name-2)))))) + + +(test test-TypableC () + "Tests various functions of the base class TypableC." + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-0-5 50) + (revision-1 100) + (revision-2 200) + (revision-3 300)) + (setf *TM-REVISION* revision-1) + (is-false (instance-of name-1)) + (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)) + (add-type name-2 top-1 :revision revision-2) + (is (= (length (union (list name-1 name-2) + (used-as-type top-1))) 2)) + (is (= (length (union (list name-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 (= (length (union (list name-2) + (used-as-type top-1))) 1)) + (add-type name-1 top-1 :revision revision-3) + (is (eql top-1 (instance-of name-1))) + (is (= (length (union (list name-1 name-2) + (used-as-type top-1))) 2)) + (is (= (length (slot-value top-1 'd::used-as-type)) 2))))) @@ -707,4 +743,5 @@ (it.bese.fiveam:run! 'test-OccurrenceC) (it.bese.fiveam:run! 'test-VariantC) (it.bese.fiveam:run! 'test-NameC) + (it.bese.fiveam:run! 'test-TypableC) ) \ No newline at end of file

1 0

[isidorus-cvs] r212 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 03:07:41 2010 New Revision: 212 Log: new-datamodel: added some unit-test for NameC; fixed a bug in delete-name and add-name 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 Fri Feb 26 03:07:41 2010 @@ -948,15 +948,16 @@ an error is thrown.") (:method ((construct TopicC) (name NameC) &key (revision *TM-REVISION*)) - (when (and (parent name) - (not (eql (parent name) construct))) + (when (and (parent name :revision revision) + (not (eql (parent name :revision revision) construct))) (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" - name construct (parent name))) + name construct (parent name :revision revision))) (let ((all-names (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) name) + when (eql (parent-construct name-assoc) + construct) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) (let ((assoc @@ -973,7 +974,7 @@ (:method ((construct TopicC) (name NameC) &key (revision (error "From delete-name(): revision must be set"))) (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) name) + when (eql (parent-construct name-assoc) construct) return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision 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 Fri Feb 26 03:07:41 2010 @@ -29,7 +29,8 @@ :test-get-item-by-psi :test-ReifiableConstructC :test-OccurrenceC - :test-VariantC)) + :test-VariantC + :test-NameC)) ;;TODO: test delete-construct @@ -573,7 +574,7 @@ (test test-VariantC () -"Tests various functions of VariantC." + "Tests various functions of VariantC." (with-fixture with-empty-db (*db-dir*) (let ((v-1 (make-instance 'VariantC)) (v-2 (make-instance 'VariantC)) @@ -618,7 +619,6 @@ (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) - (format t "-->") (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) @@ -630,6 +630,65 @@ (is-false (parent v-2)) (add-parent v-2 name-1 :revision revision-8) (is (eql name-1 (parent v-2)))))) + + +(test test-NameC () + "Tests various functions of NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (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) + (is (= (length (union (list name-1) + (names top-1))) 1)) + (add-name top-1 name-2 :revision revision-2) + (is (= (length (union (list name-1 name-2) + (names top-1))) 2)) + (is (= (length (union (list name-1) + (names top-1 :revision revision-1))) 1)) + (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 (union (list name-2) + (names top-1 :revision revision-4))) 1)) + (is (= (length (union (list name-2) + (names top-1))) 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) + (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) + (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) + (delete-parent name-2 top-2 :revision revision-8) + (is-false (parent name-2)) + (add-parent name-2 top-1 :revision revision-8) + (is (eql top-1 (parent name-2)))))) @@ -647,4 +706,5 @@ (it.bese.fiveam:run! 'test-ReifiableConstructC) (it.bese.fiveam:run! 'test-OccurrenceC) (it.bese.fiveam:run! 'test-VariantC) + (it.bese.fiveam:run! 'test-NameC) ) \ No newline at end of file

1 0

[isidorus-cvs] r211 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 02:58:57 2010 New Revision: 211 Log: new-datamodel: merged the generic functions delete-parent, so there is only one generic function with the signature ((construct CharacteristicC) (parent-construct ReifiableConstructC) &key (revision (error "From delete-parent(): revision must be set"))); added some unit-tests for the class 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 Fri Feb 26 02:58:57 2010 @@ -493,7 +493,7 @@ associates characteristics with topics.")) -(defpclass VariantAssociationC(CharateristicAssociationC) +(defpclass VariantAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct :initform (error "From VariantAssociationC(): parent-construct must be set") @@ -1187,8 +1187,8 @@ scopable-construct.") (:method ((construct NameC) (variant VariantC) &key (revision *TM-REVISION*)) - (when (and (parent variant) - (not (eql (parent variant) construct))) + (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))) (let ((all-variants @@ -1285,29 +1285,16 @@ (defgeneric delete-parent (construct parent-construct &key revision) (:documentation "Sets the assoication-object between the passed - constructs as marded-as-deleted.")) - - -(defmethod delete-parent ((construct CharacteristicC) (parent-construct TopicC) - &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 NameC) - &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 (characteristic parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct)) + 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))) ;;; PlayerAssociationC 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 Fri Feb 26 02:58:57 2010 @@ -518,7 +518,7 @@ (with-fixture with-empty-db (*db-dir*) (let ((occ-1 (make-instance 'OccurrenceC)) (occ-2 (make-instance 'OccurrenceC)) - (top (make-instance 'TopicC)) + (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) (revision-1 100) (revision-2 200) @@ -530,46 +530,46 @@ (revision-8 800)) (setf *TM-REVISION* revision-1) (is-false (parent occ-1)) - (is-false (occurrences top)) - (add-occurrence top occ-1 :revision revision-1) + (is-false (occurrences top-1)) + (add-occurrence top-1 occ-1 :revision revision-1) (is (= (length (union (list occ-1) - (occurrences top))) 1)) - (add-occurrence top occ-2 :revision revision-2) + (occurrences top-1))) 1)) + (add-occurrence top-1 occ-2 :revision revision-2) (is (= (length (union (list occ-1 occ-2) - (occurrences top))) 2)) + (occurrences top-1))) 2)) (is (= (length (union (list occ-1) - (occurrences top :revision revision-1))) 1)) - (add-occurrence top occ-2 :revision revision-3) - (is (= (length (d::slot-p top 'd::occurrences)) 2)) - (delete-occurrence top occ-1 :revision revision-4) + (occurrences top-1 :revision revision-1))) 1)) + (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 (union (list occ-2) - (occurrences top :revision revision-4))) 1)) + (occurrences top-1 :revision revision-4))) 1)) (is (= (length (union (list occ-2) - (occurrences top))) 1)) + (occurrences top-1))) 1)) (is (= (length (union (list occ-1 occ-2) - (occurrences top :revision revision-2))) 2)) - (add-occurrence top occ-1 :revision revision-4) + (occurrences top-1 :revision revision-2))) 2)) + (add-occurrence top-1 occ-1 :revision revision-4) (is (= (length (union (list occ-2 occ-1) - (occurrences top))) 2)) + (occurrences top-1))) 2)) (signals error (add-occurrence top-2 occ-1 :revision revision-4)) - (delete-occurrence top occ-1 :revision revision-5) + (delete-occurrence top-1 occ-1 :revision revision-5) (is (= (length (union (list occ-2) - (occurrences top :revision revision-5))) 1)) + (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)) - (delete-parent occ-2 top :revision revision-4) + (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 (parent occ-2 :revision revision-3))) - (add-parent occ-2 top :revision revision-5) + (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 (parent occ-2))) - (delete-parent occ-2 top :revision revision-6) + (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) (delete-parent occ-2 top-2 :revision revision-8) (is-false (parent occ-2)) - (add-parent occ-2 top :revision revision-8) - (is (eql top (parent occ-2)))))) + (add-parent occ-2 top-1 :revision revision-8) + (is (eql top-1 (parent occ-2)))))) (test test-VariantC () @@ -577,14 +577,59 @@ (with-fixture with-empty-db (*db-dir*) (let ((v-1 (make-instance 'VariantC)) (v-2 (make-instance 'VariantC)) - (name (make-instance 'NameC)) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) (revision-1 100) (revision-2 200) (revision-3 300) - (revision-4 400)) + (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) + (is (= (length (union (list v-1) + (variants name-1))) 1)) + (add-variant name-1 v-2 :revision revision-2) + (is (= (length (union (list v-1 v-2) + (variants name-1))) 2)) + (is (= (length (union (list v-1) + (variants name-1 :revision revision-1))) 1)) + (add-variant name-1 v-2 :revision revision-3) + (is (= (length (d::slot-p name-1 'd::variants)) 2)) + (delete-variant name-1 v-1 :revision revision-4) + (is (= (length (union (list v-2) + (variants name-1 :revision revision-4))) 1)) + (is (= (length (union (list v-2) + (variants name-1))) 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) + (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) + (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) + (format t "-->") + (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))))))

1 0

[isidorus-cvs] r210 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 02:14:11 2010 New Revision: 210 Log: new-datamodel: merged the generic functions add-parent, so there is only one for the parents TopicC and NameC; added some unit-tests for add-parent, delete-parent and parent 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 Fri Feb 26 02:14:11 2010 @@ -331,7 +331,7 @@ ;;; characteristics ... (defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) - ((parent :associate (CharacteriticAssociationC characteristic) + ((parent :associate (CharacteristicAssociationC characteristic) :inherit t :documentation "Assocates the characterist obejct with the parent-association.") @@ -948,13 +948,12 @@ an error is thrown.") (:method ((construct TopicC) (name NameC) &key (revision *TM-REVISION*)) - (when (not (eql (parent name) construct)) + (when (and (parent name) + (not (eql (parent name) construct))) (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" name construct (parent name))) (let ((all-names - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'names))))) + (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) when (eql (parent-construct name-assoc) name) @@ -998,14 +997,12 @@ an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision *TM-REVISION*)) - (when (and (parent occurrence) + (when (and (parent occurrence :revision revision) (not (eql (parent occurrence) 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))) (let ((all-occurrences - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'occurrences))))) + (map 'list #'characteristic (slot-p construct 'occurrences)))) (if (find occurrence all-occurrences) (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) when (eql (parent-construct occ-assoc) construct) @@ -1190,13 +1187,12 @@ scopable-construct.") (:method ((construct NameC) (variant VariantC) &key (revision *TM-REVISION*)) - (when (not (eql (parent variant) construct)) + (when (and (parent variant) + (not (eql (parent variant) 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))) (let ((all-variants - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'variants))))) + (map 'list #'characteristic (slot-p construct 'variants)))) (if (find variant all-variants) (let ((variant-assoc (loop for variant-assoc in (slot-p construct 'variants) @@ -1252,60 +1248,39 @@ (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.")) - - -(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC) - &key (revision *TM-REVISION*)) - (let ((already-set-topic - (map 'list #'parent-construct - (filter-slot-value-by-revision construct 'parent - :start-revision revision)))) - (cond ((and already-set-topic - (eql (first already-set-topic) parent-construct)) - (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))) - ((not already-set-topic) - (let ((assoc - (make-instance (if (typep construct 'OccurrenceC) - 'OccurrenceAssociationC - 'NameAssociationC) - :parent-construct parent-construct - :characteristic construct))) - (add-to-version-history assoc :start-revision revision))) - (t - (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" - construct parent-construct already-set-topic))) - construct)) - - -(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC) - &key (revision *TM-REVISION*)) - (let ((already-set-name - (map 'list #'characteristic - (filter-slot-value-by-revision construct 'parent - :start-revision revision)))) - (cond ((and already-set-name - (eql (first already-set-name) parent-construct)) + 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 (characteristic parent-assoc)) + when (eql parent-construct + (parent-construct parent-assoc)) return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) - ((not already-set-name) - (let ((assoc - (make-instance 'VariantAssociationC - :parent-construct parent-construct - :characteristic construct))) - (add-to-version-history assoc :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc :start-revision revision)) (t - (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" - construct parent-construct already-set-name))) - construct)) + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (let ((assoc (make-instance association-type + :characteristic construct + :parent-construct parent-construct))) + (add-to-version-history assoc :start-revision revision)))))) + construct)) (defgeneric delete-parent (construct parent-construct &key 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 Fri Feb 26 02:14:11 2010 @@ -28,7 +28,8 @@ :test-get-item-by-locator :test-get-item-by-psi :test-ReifiableConstructC - :test-OccurrenceC)) + :test-OccurrenceC + :test-VariantC)) ;;TODO: test delete-construct @@ -518,10 +519,15 @@ (let ((occ-1 (make-instance 'OccurrenceC)) (occ-2 (make-instance 'OccurrenceC)) (top (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) (revision-1 100) (revision-2 200) (revision-3 300) - (revision-4 400)) + (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)) @@ -544,7 +550,42 @@ (occurrences top :revision revision-2))) 2)) (add-occurrence top occ-1 :revision revision-4) (is (= (length (union (list occ-2 occ-1) - (occurrences top))) 2))))) + (occurrences top))) 2)) + (signals error (add-occurrence top-2 occ-1 :revision revision-4)) + (delete-occurrence top occ-1 :revision revision-5) + (is (= (length (union (list occ-2) + (occurrences top :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)) + (delete-parent occ-2 top :revision revision-4) + (is-false (parent occ-2 :revision revision-4)) + (is (eql top (parent occ-2 :revision revision-3))) + (add-parent occ-2 top :revision revision-5) + (is-false (parent occ-2 :revision revision-4)) + (is (eql top (parent occ-2))) + (delete-parent occ-2 top :revision revision-6) + (add-parent occ-2 top-2 :revision revision-7) + (delete-parent occ-2 top-2 :revision revision-8) + (is-false (parent occ-2)) + (add-parent occ-2 top :revision revision-8) + (is (eql top (parent occ-2)))))) + + +(test test-VariantC () +"Tests various functions of VariantC." + (with-fixture with-empty-db (*db-dir*) + (let ((v-1 (make-instance 'VariantC)) + (v-2 (make-instance 'VariantC)) + (name (make-instance 'NameC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400)) + (setf *TM-REVISION* revision-1) + + ))) + (defun run-datamodel-tests() @@ -560,4 +601,5 @@ (it.bese.fiveam:run! 'test-get-item-by-psi) (it.bese.fiveam:run! 'test-ReifiableConstructC) (it.bese.fiveam:run! 'test-OccurrenceC) + (it.bese.fiveam:run! 'test-VariantC) ) \ No newline at end of file

1 0

[isidorus-cvs] r209 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 25 Feb '10

25 Feb '10

Author: lgiessmann Date: Thu Feb 25 16:36:10 2010 New Revision: 209 Log: new-datamodel: added some unit-tests for add-occurrence, delete-occurrence, occurrences; fixed some bugs in these funtions 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 Feb 25 16:36:10 2010 @@ -486,7 +486,7 @@ :accessor characteristic :inherit t :initform (error "From CharacteristicCAssociation(): characteristic must be set") - :associate CharactersiticC + :associate CharacteristicC :documentation "Associates this object with the actual characteristic object.")) (:documentation "An abstract base class for all association-objects that @@ -986,7 +986,7 @@ with the passed construct and the passed version.") (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision - construct 'occurences :start-revision revision))) + construct 'occurrences :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -998,7 +998,8 @@ an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision *TM-REVISION*)) - (when (not (eql (parent occurrence) construct)) + (when (and (parent occurrence) + (not (eql (parent occurrence) 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))) (let ((all-occurrences @@ -1007,7 +1008,7 @@ (slot-p construct 'occurrences))))) (if (find occurrence all-occurrences) (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) occurrence) + when (eql (parent-construct occ-assoc) construct) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) (let ((assoc @@ -1024,7 +1025,7 @@ (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision (error "From delete-occurrence(): revision must be set"))) (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) occurrence) + when (eql (parent-construct occ-assoc) construct) return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision 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 Thu Feb 25 16:36:10 2010 @@ -27,14 +27,13 @@ :test-get-item-by-item-identifier :test-get-item-by-locator :test-get-item-by-psi - :test-ReifiableConstructC)) + :test-ReifiableConstructC + :test-OccurrenceC)) ;;TODO: test delete-construct -;;TODO: test merge-constructs when merging was caused by an item-dentifier -;;TODO: test merge-constructs when merging was caused by an psi -;;TODO: test merge-constructs when merging was caused by an subject-locator -;;TODO: test merge-constructs when merging was caused by a topic-id +;;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 @@ -513,6 +512,41 @@ (is-false (reified-construct reifier-top :revision 50))))) +(test test-OccurrenceC () + "Tests various functions of OccurrenceC." + (with-fixture with-empty-db (*db-dir*) + (let ((occ-1 (make-instance 'OccurrenceC)) + (occ-2 (make-instance 'OccurrenceC)) + (top (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400)) + (setf *TM-REVISION* revision-1) + (is-false (parent occ-1)) + (is-false (occurrences top)) + (add-occurrence top occ-1 :revision revision-1) + (is (= (length (union (list occ-1) + (occurrences top))) 1)) + (add-occurrence top occ-2 :revision revision-2) + (is (= (length (union (list occ-1 occ-2) + (occurrences top))) 2)) + (is (= (length (union (list occ-1) + (occurrences top :revision revision-1))) 1)) + (add-occurrence top occ-2 :revision revision-3) + (is (= (length (d::slot-p top 'd::occurrences)) 2)) + (delete-occurrence top occ-1 :revision revision-4) + (is (= (length (union (list occ-2) + (occurrences top :revision revision-4))) 1)) + (is (= (length (union (list occ-2) + (occurrences top))) 1)) + (is (= (length (union (list occ-1 occ-2) + (occurrences top :revision revision-2))) 2)) + (add-occurrence top occ-1 :revision revision-4) + (is (= (length (union (list occ-2 occ-1) + (occurrences top))) 2))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -525,4 +559,5 @@ (it.bese.fiveam:run! 'test-get-item-by-locator) (it.bese.fiveam:run! 'test-get-item-by-psi) (it.bese.fiveam:run! 'test-ReifiableConstructC) + (it.bese.fiveam:run! 'test-OccurrenceC) ) \ No newline at end of file

1 0

[isidorus-cvs] r208 - branches/new-datamodel/src/rest_interface trunk/src/rest_interface
by Lukas Giessmann 25 Feb '10

25 Feb '10

Author: lgiessmann Date: Thu Feb 25 15:45:39 2010 New Revision: 208 Log: rest-interface: fixed a bug in the restful-handler return-overview that caused a memory-leak Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp 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 Thu Feb 25 15:45:39 2010 @@ -331,15 +331,15 @@ (defun return-overview (&optional param) "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) - (handler-case (let ((json-string - (with-reader-lock - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - json-string) - (Condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err))))) + (with-reader-lock + (handler-case (let ((json-string + (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + json-string) + (Condition (err) (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) ;; ============================================================================= @@ -385,4 +385,4 @@ (setf ret-str (concatenate 'string ret-str (subseq str idx (1+ idx)))) (incf idx))) (unless (< idx (length str)) - (return ret-str))))))) \ No newline at end of file + (return ret-str))))))) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Feb 25 15:45:39 2010 @@ -331,15 +331,15 @@ (defun return-overview (&optional param) "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) - (handler-case (let ((json-string - (with-reader-lock - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - json-string) - (Condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err))))) + (with-reader-lock + (handler-case (let ((json-string + (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + json-string) + (Condition (err) (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) ;; =============================================================================

1 0

[isidorus-cvs] r207 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 25 Feb '10

25 Feb '10

Author: lgiessmann Date: Thu Feb 25 14:20:51 2010 New Revision: 207 Log: new-datamodel: added some unit-tests for add-reifier, reifier and delete-reifier; fixed alos msome problems in these functions; changed some key-parameters --> (reivision 0) was changed to (revision *TM-REVISION*) in all adder-functions, e.g. add-psi 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 Feb 25 14:20:51 2010 @@ -94,6 +94,7 @@ (in-package :datamodel) +;;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 @@ -253,7 +254,7 @@ :inherit t :documentation "A relation to all item-identifiers of this construct.") - (reifier :associate (ReifierAssociationC reified-construct) + (reifier :associate (ReifierAssociationC reifiable-construct) :inherit t :documentation "A relation to a reifier-topic.")) (:documentation "Reifiable constructs as per TMDM.")) @@ -316,7 +317,7 @@ :documentation "Contains all association objects that relate a topic that is a theme with its scoppable object.") - (reified-construct :associate (ReifiedAssociationC reifier-topic) + (reified-construct :associate (ReifierAssociationC reifier-topic) :documentation "Contains all association objects that relate a topic that is a reifier with its reified object.") @@ -411,7 +412,7 @@ :initform (error "From ReifierAssociation(): reifiable-construct must be set") :associate ReifiableConstructC :documentation "The actual construct which is reified - by a topic.") + by a topic.") (reifier-topic :initarg :reifier-topic :accessor reifier-topic :initform (error "From ReifierAssociationC(): reifier-topic must be set") @@ -786,7 +787,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (topic-identifier TopicIdentificationC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-ids (map 'list #'identifier (slot-p construct 'topic-identifiers))) (construct-to-be-merged @@ -840,7 +841,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (psi PersistentIdC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-ids (map 'list #'identifier (slot-p construct 'psis))) (construct-to-be-merged @@ -893,7 +894,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (locator SubjectLocatorC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-ids (map 'list #'identifier (slot-p construct 'locators))) (construct-to-be-merged @@ -946,7 +947,7 @@ If the passed name already owns another object an error is thrown.") (:method ((construct TopicC) (name NameC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (when (not (eql (parent name) construct)) (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" name construct (parent name))) @@ -959,11 +960,12 @@ when (eql (parent-construct name-assoc) name) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) - (make-instance 'NameAssociationC - :start-revision revision - :parent-construct construct - :characteristic name)) - construct))) + (let ((assoc + (make-instance 'NameAssociationC + :parent-construct construct + :characteristic name))) + (add-to-version-history assoc :start-revision revision)))) + construct)) (defgeneric delete-name (construct name &key revision) @@ -995,7 +997,7 @@ If the passed occurrence already owns another object an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (when (not (eql (parent occurrence) 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))) @@ -1008,11 +1010,12 @@ when (eql (parent-construct occ-assoc) occurrence) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) - (make-instance 'OccurrenceAssociationC - :start-revision revision - :parent-construct construct - :characteristic occurrence)) - construct))) + (let ((assoc + (make-instance 'OccurrenceAssociationC + :parent-construct construct + :characteristic occurrence))) + (add-to-version-history assoc :start-revision revision)))) + construct)) (defgeneric delete-occurrence (construct occurrence &key revision) @@ -1061,7 +1064,8 @@ (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'reified-construct :start-revision revision))) - (map 'list #'reifiable-construct assocs)))) + (when assocs + (reifiable-construct (first assocs)))))) (defgeneric in-topicmaps (construct &key revision) @@ -1184,7 +1188,7 @@ (:documentation "Adds the given theme-topic to the passed scopable-construct.") (:method ((construct NameC) (variant VariantC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (when (not (eql (parent variant) 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))) @@ -1198,10 +1202,11 @@ when (eql (characteristic variant-assoc) variant) return variant-assoc))) (add-to-version-history variant-assoc :start-revision revision)) - (make-instance 'VariantAssociationC - :start-revision revision - :characteristic variant - :parent-construct construct))) + (let ((assoc + (make-instance 'VariantAssociationC + :characteristic variant + :parent-construct construct))) + (add-to-version-history assoc :start-revision revision)))) construct)) @@ -1250,7 +1255,7 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-topic (map 'list #'parent-construct (filter-slot-value-by-revision construct 'parent @@ -1264,12 +1269,13 @@ return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) ((not already-set-topic) - (make-instance (if (typep construct 'OccurrenceC) - 'OccurrenceAssociationC - 'NameAssociationC) - :start-revision revision - :parent-construct parent-construct - :characteristic construct)) + (let ((assoc + (make-instance (if (typep construct 'OccurrenceC) + 'OccurrenceAssociationC + 'NameAssociationC) + :parent-construct parent-construct + :characteristic construct))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" construct parent-construct already-set-topic))) @@ -1277,7 +1283,7 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct NameC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-name (map 'list #'characteristic (filter-slot-value-by-revision construct 'parent @@ -1290,10 +1296,11 @@ return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) ((not already-set-name) - (make-instance 'VariantAssociationC - :start-revision revision - :parent-construct parent-construct - :characteristic construct)) + (let ((assoc + (make-instance 'VariantAssociationC + :parent-construct parent-construct + :characteristic construct))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" construct parent-construct already-set-name))) @@ -1448,7 +1455,7 @@ (defgeneric add-role (construct role &key revision) (:documentation "Adds the given role to the passed association-construct.") (:method ((construct AssociationC) (role RoleC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-roles (map 'list #'role (remove-if #'marked-as-deleted-p (slot-p construct 'roles))))) @@ -1458,10 +1465,11 @@ when (eql (role role-assoc) role) return role-assoc))) (add-to-version-history role-assoc :start-revision revision)) - (make-instance 'RoleAssociationC - :start-revision revision - :role role - :association construct))) + (let ((assoc + (make-instance 'RoleAssociationC + :role role + :association construct))) + (add-to-version-history assoc :start-revision revision)))) construct)) @@ -1501,7 +1509,7 @@ (defmethod add-parent ((construct RoleC) (parent-construct AssociationC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-parent (map 'list #'parent (filter-slot-value-by-revision construct 'parent @@ -1515,10 +1523,10 @@ return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) ((not already-set-parent) - (make-instance 'RoleAssociationC - :start-revision revision - :role construct - :parent-construct parent-construct)) + (let ((assoc (make-instance 'RoleAssociationC + :role construct + :parent-construct parent-construct))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a" parent-construct construct already-set-parent))) @@ -1550,7 +1558,7 @@ (defgeneric add-player (construct player-topic &key revision) (:documentation "Adds a topic as a player to a role in the given revision.") (:method ((construct RoleC) (player-topic TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-player (map 'list #'player-topic (filter-slot-value-by-revision construct 'player @@ -1563,10 +1571,10 @@ return player-assoc))) (add-to-version-history player-assoc :start-revision revision))) ((not already-set-player) - (make-instance 'PlayerAssociationC - :start-revision revision - :parent-construct construct - :player-topic player-topic)) + (let ((assoc (make-instance 'PlayerAssociationC + :parent-construct construct + :player-topic player-topic))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a" player-topic construct already-set-player))) @@ -1602,9 +1610,9 @@ with the passed construct and the passed version.") (:method ((construct ReifiableConstructC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision - construct 'item-identifiers :start-revision revision))) + construct 'reifier :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item - (reifier (first assocs)))))) + (reifier-topic (first assocs)))))) (defmethod delete-construct :before ((construct ReifiableConstructC)) @@ -1624,7 +1632,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-ids (map 'list #'identifier (slot-p construct 'item-identifiers))) (construct-to-be-merged @@ -1669,13 +1677,16 @@ If the reifier-topic reifies already another construct the reified-constructs are merged.") (:method ((construct ReifiableConstructC) (reifier-topic TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((merged-reifier-topic - (when (reifier construct) - (merge-constructs (reifier construct) reifier-topic)))) + (if (reifier construct) + (merge-constructs (reifier construct) reifier-topic) + reifier-topic))) (let ((all-constructs - (remove-if #'marked-as-deleted-p - (slot-p reifier-topic 'reified-construct)))) + (let ((inner-construct (reified-construct merged-reifier-topic + :revision revision))) + (when inner-construct + (list inner-construct))))) (cond ((find construct all-constructs) (let ((reifier-assoc (loop for reifier-assoc in @@ -1688,11 +1699,12 @@ (all-constructs (merge-constructs (first all-constructs) construct)) (t - (make-instance 'ReifierAssociationC - :start-revision revision - :reifiable-construct construct - :reifier-topic merged-reifier-topic) - construct)))))) + (let ((assoc + (make-instance 'ReifierAssociationC + :reifiable-construct construct + :reifier-topic merged-reifier-topic))) + (add-to-version-history assoc :start-revision revision)))) + construct)))) (defgeneric delete-reifier (construct reifier &key revision) @@ -1729,7 +1741,7 @@ (:documentation "Adds the given theme-topic to the passed scopable-construct.") (:method ((construct ScopableC) (theme-topic TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-themes (map 'list #'theme-topic (remove-if #'marked-as-deleted-p (slot-p construct 'themes))))) @@ -1739,10 +1751,11 @@ when (eql (theme-topic theme-assoc) theme-topic) return theme-assoc))) (add-to-version-history theme-assoc :start-revision revision)) - (make-instance 'ScopeAssociationC - :start-revision revision - :theme-topic theme-topic - :scopable-construct construct))) + (let ((assoc + (make-instance 'ScopeAssociationCn + :theme-topic theme-topic + :scopable-construct construct))) + (add-to-version-history assoc :start-revision revision)))) construct)) @@ -1782,7 +1795,7 @@ typed construct if there is no other type-topic set at the same revision.") (:method ((construct TypableC) (type-topic TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-type (map 'list #'type-topic (filter-slot-value-by-revision construct 'instance-of @@ -1795,10 +1808,11 @@ return type-assoc))) (add-to-version-history type-assoc :start-revision revision))) ((not already-set-type) - (make-instance 'TypeAssociationC - :start-revision revision - :type-topic type-topic - :typable-construct construct)) + (let ((assoc + (make-instance 'TypeAssociationC + :type-topic type-topic + :typable-construct construct))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a" construct type-topic already-set-type))) @@ -1831,10 +1845,11 @@ ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defgeneric merge-constructs(construc-1 construct-2 &key revision) +(defgeneric merge-constructs(construct-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) - &key (revision 0)) - (or construct-1 construct-2 revision))) + &key (revision *TM-REVISION*)) + (or revision) + (if construct-1 construct-1 construct-2))) (defgeneric make-construct (class-symbol &key start-revision &allow-other-keys) 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 Feb 25 14:20:51 2010 @@ -26,13 +26,18 @@ :test-get-item-by-id :test-get-item-by-item-identifier :test-get-item-by-locator - :test-get-item-by-psi)) + :test-get-item-by-psi + :test-ReifiableConstructC)) -;;TODO: test merges-constructs when merging was caused by an item-dentifier -;;TODO: test merges-constructs when merging was caused by an psi -;;TODO: test merges-constructs when merging was caused by an subject-locator -;;TODO: test merges-constructs when merging was caused by a topic-id +;;TODO: test delete-construct +;;TODO: test merge-constructs when merging was caused by an item-dentifier +;;TODO: test merge-constructs when merging was caused by an psi +;;TODO: test merge-constructs when merging was caused by an subject-locator +;;TODO: test merge-constructs when merging was caused by 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 @@ -367,7 +372,7 @@ (test test-get-item-by-item-identifier () - "Tests the function test-get-item-by-id." + "Tests the function test-get-item-by-item-identifier." (with-fixture with-empty-db (*db-dir*) (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) @@ -409,7 +414,7 @@ (test test-get-item-by-locator () - "Tests the function test-get-item-by-id." + "Tests the function test-get-item-by-locator." (with-fixture with-empty-db (*db-dir*) (let ((sl-1 (make-instance 'SubjectLocatorC :uri "sl-1")) @@ -451,7 +456,7 @@ (test test-get-item-by-psi () - "Tests the function test-get-item-by-id." + "Tests the function test-get-item-by-psi." (with-fixture with-empty-db (*db-dir*) (let ((psi-1 (make-instance 'PersistentIdC :uri "psi-1")) @@ -492,6 +497,22 @@ (is (eql top-3 (get-item-by-locator "psi-1")))))) +(test test-ReifiableConstructC () + "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))) + (is-false (reifier reified-rc)) + (is-false (reified-construct reifier-top)) + (add-reifier reified-rc reifier-top :revision 100) + (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))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -503,4 +524,5 @@ (it.bese.fiveam:run! 'test-get-item-by-item-identifier) (it.bese.fiveam:run! 'test-get-item-by-locator) (it.bese.fiveam:run! 'test-get-item-by-psi) + (it.bese.fiveam:run! 'test-ReifiableConstructC) ) \ No newline at end of file

1 0

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

24 Feb '10

Author: lgiessmann Date: Wed Feb 24 14:59:58 2010 New Revision: 206 Log: new-datamodel: added unit-tests for: get-item-by-item-identifier, get-item-by-psi and get-item-by-locator; optimized the function get item-by-identifier 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 Feb 24 14:59:58 2010 @@ -83,7 +83,7 @@ :get-revision :get-item-by-id :get-item-by-psi - :get-item-by-item-identnfier + :get-item-by-item-identifier :get-item-by-locator :string-integer-p @@ -94,11 +94,6 @@ (in-package :datamodel) - -;;TODO: implement get-item-by-id(TopicC) + unit-tests -;;TODO: implement get-item-by-psi(TopicC) + unit-tests -;;TODO: implement get-item-by-locator(TopicC) + unit-tests -;;TODO: implement get-item-by-item-identifier(ReifiableConstructC) + unit-tests ;;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 @@ -1135,7 +1130,7 @@ (delete-if-not #'(lambda(id) (string= (uri id) uri)) - (get-instances-by-class identifier-type-symbol)))) + (get-instances-by-value identifier-type-symbol 'uri uri)))) (when (and possible-ids (identified-construct (first possible-ids) :revision revision)) (unless (= (length possible-ids) 1) 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 Feb 24 14:59:58 2010 @@ -23,7 +23,10 @@ :test-PersistentIdC :test-SubjectLocatorC :test-TopicIdentificationC - :test-get-item-by-id)) + :test-get-item-by-id + :test-get-item-by-item-identifier + :test-get-item-by-locator + :test-get-item-by-psi)) ;;TODO: test merges-constructs when merging was caused by an item-dentifier @@ -363,6 +366,132 @@ :revision revision))))) +(test test-get-item-by-item-identifier () + "Tests the function test-get-item-by-id." + (with-fixture with-empty-db (*db-dir*) + (let ((ii-1 (make-instance 'ItemIdentifierC + :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC + :uri "ii-2")) + (ii-3-1 (make-instance 'ItemIdentifierC + :uri "ii-3")) + (ii-3-2 (make-instance 'ItemIdentifierC + :uri "ii-3")) + (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-ii-id")) + (signals error (is-false (get-item-by-item-identifier + "any-ii-id" :error-if-nil t))) + (signals error (is-false (get-item-by-item-identifier + "any-ii-id" :error-if-nil t))) + (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) + (signals duplicate-identifier-error + (get-item-by-item-identifier "ii-3" :revision revision)) + (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"))) + (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")))))) + + +(test test-get-item-by-locator () + "Tests the function test-get-item-by-id." + (with-fixture with-empty-db (*db-dir*) + (let ((sl-1 (make-instance 'SubjectLocatorC + :uri "sl-1")) + (sl-2 (make-instance 'SubjectLocatorC + :uri "sl-2")) + (sl-3-1 (make-instance 'SubjectLocatorC + :uri "sl-3")) + (sl-3-2 (make-instance 'SubjectLocatorC + :uri "sl-3")) + (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-sl-id")) + (signals error (is-false (get-item-by-locator + "any-sl-id" :error-if-nil t))) + (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) + (signals duplicate-identifier-error + (get-item-by-locator "sl-3" :revision revision)) + (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"))) + (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")))))) + + +(test test-get-item-by-psi () + "Tests the function test-get-item-by-id." + (with-fixture with-empty-db (*db-dir*) + (let ((psi-1 (make-instance 'PersistentIdC + :uri "psi-1")) + (psi-2 (make-instance 'PersistentIdC + :uri "psi-2")) + (psi-3-1 (make-instance 'PersistentIdC + :uri "psi-3")) + (psi-3-2 (make-instance 'PersistentIdC + :uri "psi-3")) + (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-psi-id")) + (signals error (is-false (get-item-by-locator + "any-psi-id" :error-if-nil t))) + (signals error (is-false (get-item-by-locator + "any-psi-id" :error-if-nil t))) + (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) + (signals duplicate-identifier-error + (get-item-by-locator "psi-3" :revision revision)) + (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"))) + (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")))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -371,4 +500,7 @@ (it.bese.fiveam:run! 'test-SubjectLocatorC) (it.bese.fiveam:run! 'test-TopicIdentificationC) (it.bese.fiveam:run! 'test-get-item-by-id) + (it.bese.fiveam:run! 'test-get-item-by-item-identifier) + (it.bese.fiveam:run! 'test-get-item-by-locator) + (it.bese.fiveam:run! 'test-get-item-by-psi) ) \ No newline at end of file

1 0

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

24 Feb '10

Author: lgiessmann Date: Wed Feb 24 14:28:28 2010 New Revision: 205 Log: new-datamodel: fixed some problems with get-item-by-id and added some unit-tests 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 Feb 24 14:28:28 2010 @@ -94,8 +94,7 @@ (in-package :datamodel) -;;TODO: fix this line (make-instance 'TopicC :from-oid (subseq topic-id 1))))) -;; in get-item-by-id + ;;TODO: implement get-item-by-id(TopicC) + unit-tests ;;TODO: implement get-item-by-psi(TopicC) + unit-tests ;;TODO: implement get-item-by-locator(TopicC) + unit-tests @@ -265,7 +264,8 @@ (:documentation "Reifiable constructs as per TMDM.")) -(defpclass AssociationC(ReifiableConstructC ScopableC TypableC) +(defpclass AssociationC(ReifiableConstructC ScopableC TypableC + VersionedConstructC) ((roles :associate (RoleAssociationC association) :documentation "Contains all association-objects of all roles this association contains.") @@ -284,7 +284,7 @@ :documentation "Associates this object with a player-association."))) -(elephant:defpclass TopicMapC (ReifiableConstructC) +(elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC) ((topics :accessor topics :associate (TopicC in-topicmaps) :documentation "List of topics that explicitly belong to this TM.") @@ -294,7 +294,7 @@ (:documentation "Represnets a topic map.")) -(defpclass TopicC (ReifiableConstructC) +(defpclass TopicC (ReifiableConstructC VersionedConstructC) ((topic-identifiers :associate (TopicIdAssociationC parent-construct) :documentation "Contains all association objects that relate a topic with its actual @@ -749,7 +749,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 *TM-REVISION*)) + (:method ((construct PointerC) &key (revision 0)) (let ((assocs (map 'list #'parent-construct (filter-slot-value-by-revision construct 'identified-construct @@ -778,7 +778,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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'topic-identifiers :start-revision revision))) (map 'list #'identifier assocs)))) @@ -791,7 +791,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (topic-identifier TopicIdentificationC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-ids (map 'list #'identifier (slot-p construct 'topic-identifiers))) (construct-to-be-merged @@ -799,9 +799,7 @@ (when (not (eql id-owner construct)) id-owner)))) (cond (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - 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) @@ -834,7 +832,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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'psis :start-revision revision))) (map 'list #'identifier assocs)))) @@ -847,7 +845,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (psi PersistentIdC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-ids (map 'list #'identifier (slot-p construct 'psis))) (construct-to-be-merged @@ -855,9 +853,8 @@ (when (not (eql id-owner construct)) id-owner)))) (cond (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - 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) @@ -888,7 +885,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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'locators :start-revision revision))) (map 'list #'identifier assocs)))) @@ -901,7 +898,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (locator SubjectLocatorC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-ids (map 'list #'identifier (slot-p construct 'locators))) (construct-to-be-merged @@ -909,9 +906,8 @@ (when (not (eql id-owner construct)) id-owner)))) (cond (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - 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) @@ -942,7 +938,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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'names :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -955,7 +951,7 @@ If the passed name already owns another object an error is thrown.") (:method ((construct TopicC) (name NameC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (when (not (eql (parent name) construct)) (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" name construct (parent name))) @@ -991,7 +987,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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'occurences :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -1004,7 +1000,7 @@ If the passed occurrence already owns another object an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (when (not (eql (parent occurrence) 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))) @@ -1040,7 +1036,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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'player-in-roles :start-revision revision))) (map 'list #'parent-construct assocs)))) @@ -1049,7 +1045,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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'used-as-type :start-revision revision))) (map 'list #'typable-construct assocs)))) @@ -1058,7 +1054,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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'used-as-theme :start-revision revision))) (map 'list #'scopable-construct assocs)))) @@ -1067,7 +1063,7 @@ (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 *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'reified-construct :start-revision revision))) (map 'list #'reifiable-construct assocs)))) @@ -1077,7 +1073,7 @@ (:documentation "Returns all TopicMapS-obejcts where the constrict is contained in.")) -(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*)) +(defmethod in-topicmaps ((topic TopicC) &key (revision 0)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) @@ -1088,7 +1084,7 @@ if the topic already existed in this revision and returns nil otherwise. If no item meeting the constraints was found, then the return value is either NIL or an error is thrown, depending on error-if-nil." - (declare (string topic-id) (integer revision) (string xtm-id)) + (declare (string topic-id) (integer revision)) (let ((result (if xtm-id (let ((possible-top-ids @@ -1105,19 +1101,25 @@ (when (and possible-top-ids (identified-construct (first possible-top-ids) :revision revision)) (unless (= (length possible-top-ids) 1) - (error (make-condition 'duplicate-identifier-error - :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" - possible-top-ids topic-id xtm-id) - :uri topic-id))) + (error + (make-condition 'duplicate-identifier-error + :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" + possible-top-ids topic-id xtm-id) + :uri topic-id))) (identified-construct (first possible-top-ids) :revision revision) ;no revision need not to be chaecked, since the revision ;is implicitely checked by the function identified-construct )) (when (and (> (length topic-id) 0) - (eql (elt 0 topic-id) #\t) + (eql (elt topic-id 0) #\t) (string-integer-p (subseq topic-id 1))) - (elephant::controller-recreate-instance elephant::*store-controller* (subseq topic-id 1)))))) + (let ((top-from-oid + (elephant::controller-recreate-instance + elephant::*store-controller* + (parse-integer (subseq topic-id 1))))) + (when (find-item-by-revision top-from-oid revision) + top-from-oid)))))) (if (and error-if-nil (not result)) (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision) result))) @@ -1176,7 +1178,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 *TM-REVISION*)) + (:method ((construct NameC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'variants :start-revision revision))) @@ -1187,7 +1189,7 @@ (:documentation "Adds the given theme-topic to the passed scopable-construct.") (:method ((construct NameC) (variant VariantC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (when (not (eql (parent variant) 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))) @@ -1239,7 +1241,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 *TM-REVISION*)) + (:method ((construct CharacteristicC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'parent :start-revision revision))) @@ -1253,7 +1255,7 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-topic (map 'list #'parent-construct (filter-slot-value-by-revision construct 'parent @@ -1280,7 +1282,7 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct NameC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-name (map 'list #'characteristic (filter-slot-value-by-revision construct 'parent @@ -1441,7 +1443,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 *TM-REVISION*)) + (:method ((construct AssociationC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'roles :start-revision revision))) @@ -1451,7 +1453,7 @@ (defgeneric add-role (construct role &key revision) (:documentation "Adds the given role to the passed association-construct.") (:method ((construct AssociationC) (role RoleC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-roles (map 'list #'role (remove-if #'marked-as-deleted-p (slot-p construct 'roles))))) @@ -1481,7 +1483,7 @@ construct))) -(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*)) +(defmethod in-topicmaps ((association AssociationC) &key (revision 0)) (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) @@ -1494,7 +1496,7 @@ (delete-construct assoc))) -(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*)) +(defmethod parent ((construct RoleC) &key (revision 0)) "Returns the construct's parent corresponding to the given revision." (let ((valid-associations (filter-slot-value-by-revision construct 'parent @@ -1504,7 +1506,7 @@ (defmethod add-parent ((construct RoleC) (parent-construct AssociationC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-parent (map 'list #'parent (filter-slot-value-by-revision construct 'parent @@ -1542,7 +1544,7 @@ (defgeneric player (construct &key revision) (:documentation "Returns the construct's player corresponding to the given revision.") - (:method ((construct RoleC) &key (revision *TM-REVISION*)) + (:method ((construct RoleC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'player :start-revision revision))) @@ -1553,7 +1555,7 @@ (defgeneric add-player (construct player-topic &key revision) (:documentation "Adds a topic as a player to a role in the given revision.") (:method ((construct RoleC) (player-topic TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-player (map 'list #'player-topic (filter-slot-value-by-revision construct 'player @@ -1594,7 +1596,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 *TM-REVISION*)) + (:method ((construct ReifiableConstructC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) (map 'list #'identifier assocs)))) @@ -1603,7 +1605,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 *TM-REVISION*)) + (:method ((construct ReifiableConstructC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item @@ -1627,7 +1629,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-ids (map 'list #'identifier (slot-p construct 'item-identifiers))) (construct-to-be-merged @@ -1635,9 +1637,8 @@ (when (not (eql id-owner construct)) id-owner)))) (cond (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - 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) @@ -1673,7 +1674,7 @@ If the reifier-topic reifies already another construct the reified-constructs are merged.") (:method ((construct ReifiableConstructC) (reifier-topic TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((merged-reifier-topic (when (reifier construct) (merge-constructs (reifier construct) reifier-topic)))) @@ -1722,7 +1723,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 *TM-REVISION*)) + (:method ((construct ScopableC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'themes :start-revision revision))) @@ -1733,7 +1734,7 @@ (:documentation "Adds the given theme-topic to the passed scopable-construct.") (:method ((construct ScopableC) (theme-topic TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-themes (map 'list #'theme-topic (remove-if #'marked-as-deleted-p (slot-p construct 'themes))))) @@ -1773,7 +1774,7 @@ (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed revision.") - (:method ((construct TypableC) &key (revision *TM-REVISION*)) + (:method ((construct TypableC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'instance-of :start-revision revision))) @@ -1786,7 +1787,7 @@ typed construct if there is no other type-topic set at the same revision.") (:method ((construct TypableC) (type-topic TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-type (map 'list #'type-topic (filter-slot-value-by-revision construct 'instance-of @@ -1837,7 +1838,7 @@ ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric merge-constructs(construc-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (or construct-1 construct-2 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 Wed Feb 24 14:28:28 2010 @@ -14,13 +14,16 @@ :it.bese.FiveAM :fixtures :unittests-constants) + (:import-from :exceptions + duplicate-identifier-error) (:export :run-datamodel-tests :test-VersionInfoC :test-VersionedConstructC :test-ItemIdentifierC :test-PersistentIdC :test-SubjectLocatorC - :test-TopicIdentificationC)) + :test-TopicIdentificationC + :test-get-item-by-id)) ;;TODO: test merges-constructs when merging was caused by an item-dentifier @@ -302,6 +305,64 @@ (is-false (topic-identifiers topic-1 :revision revision-3-5))))) +(test test-get-item-by-id () + "Tests the function test-get-item-by-id." + (with-fixture with-empty-db (*db-dir*) + (let ((top-id-1 (make-instance 'TopicIdentificationC + :uri "topid-1" + :xtm-id "xtm-id-1")) + (top-id-2 (make-instance 'TopicIdentificationC + :uri "topid-2" + :xtm-id "xtm-id-2")) + (top-id-3-1 (make-instance 'TopicIdentificationC + :uri "topid-3" + :xtm-id "xtm-id-3")) + (top-id-3-2 (make-instance 'TopicIdentificationC + :uri "topid-3" + :xtm-id "xtm-id-3")) + (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")) + (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))) + (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) + (signals duplicate-identifier-error + (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision revision)) + (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"))) + (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")) + (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) + (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"))) + (is (eql top-3 + (get-item-by-id + (concatenate 'string "t" (write-to-string + (elephant::oid top-3)))))) + (is-false (get-item-by-id + (concatenate 'string "t" (write-to-string + (elephant::oid top-3))) + :revision revision))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -309,4 +370,5 @@ (it.bese.fiveam:run! 'test-PersistentIdC) (it.bese.fiveam:run! 'test-SubjectLocatorC) (it.bese.fiveam:run! 'test-TopicIdentificationC) + (it.bese.fiveam:run! 'test-get-item-by-id) ) \ No newline at end of file

1 0

[isidorus-cvs] r204 - branches/new-datamodel/src/model trunk/src/model
by Lukas Giessmann 24 Feb '10

24 Feb '10

Author: lgiessmann Date: Wed Feb 24 11:04:46 2010 New Revision: 204 Log: new-datamodel: added the functions get-item-by-item-identifier, get-item-by-psi, get-item-by-locator; fixed a bug in the function get-item-by-id -> ticket #65 Modified: branches/new-datamodel/src/model/datamodel.lisp trunk/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 Wed Feb 24 11:04:46 2010 @@ -10,6 +10,8 @@ (defpackage :datamodel (:use :cl :elephant :constants) (:nicknames :d) + (:import-from :exceptions + duplicate-identifier-error) (:export ;;classes :TopicMapC :AssociationC @@ -79,6 +81,11 @@ :in-topicmaps :delete-construct :get-revision + :get-item-by-id + :get-item-by-psi + :get-item-by-item-identnfier + :get-item-by-locator + :string-integer-p ;;globals :*TM-REVISION* @@ -87,6 +94,12 @@ (in-package :datamodel) +;;TODO: fix this line (make-instance 'TopicC :from-oid (subseq topic-id 1))))) +;; in get-item-by-id +;;TODO: implement get-item-by-id(TopicC) + unit-tests +;;TODO: implement get-item-by-psi(TopicC) + unit-tests +;;TODO: implement get-item-by-locator(TopicC) + unit-tests +;;TODO: implement get-item-by-item-identifier(ReifiableConstructC) + unit-tests ;;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 @@ -609,6 +622,13 @@ (get-universal-time)) +(defun string-integer-p (integer-as-string) + "Returns t if the passed string can be parsed to an integer." + (handler-case (when (parse-integer integer-as-string) + t) + (condition () nil))) + + ;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; VersionInfocC (defmethod delete-construct :before ((version-info VersionInfoC)) @@ -1061,6 +1081,96 @@ (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)) + "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 + if the topic already existed in this revision and returns nil otherwise. + If no item meeting the constraints was found, then the return value is either + NIL or an error is thrown, depending on error-if-nil." + (declare (string topic-id) (integer revision) (string xtm-id)) + (let ((result + (if xtm-id + (let ((possible-top-ids + (delete-if-not + #'(lambda(top-id) + (and (string= (xtm-id top-id) xtm-id) + (string= (uri top-id) topic-id))) + ;fixes a bug in get-instances-by-value that does a + ;case-insensitive comparision + (elephant:get-instances-by-value + 'TopicIdentificationC + 'uri + topic-id)))) + (when (and possible-top-ids + (identified-construct (first possible-top-ids) :revision revision)) + (unless (= (length possible-top-ids) 1) + (error (make-condition 'duplicate-identifier-error + :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" + possible-top-ids topic-id xtm-id) + :uri topic-id))) + (identified-construct (first possible-top-ids) + :revision revision) + ;no revision need not to be chaecked, since the revision + ;is implicitely checked by the function identified-construct + )) + (when (and (> (length topic-id) 0) + (eql (elt 0 topic-id) #\t) + (string-integer-p (subseq topic-id 1))) + (elephant::controller-recreate-instance elephant::*store-controller* (subseq topic-id 1)))))) + (if (and error-if-nil (not result)) + (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision) + result))) + + +(defun get-item-by-identifier (uri &key (revision 0) + (identifier-type-symbol 'PersistentIdC) + (error-if-nil nil)) + "Returns the construct that is bound to the given identifier-uri." + (declare (string uri) (integer revision) (symbol identifier-type-symbol)) + (let ((result + (let ((possible-ids + (delete-if-not + #'(lambda(id) + (string= (uri id) uri)) + (get-instances-by-class identifier-type-symbol)))) + (when (and possible-ids + (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" + possible-ids uri) + :uri uri))) + (identified-construct (first possible-ids) + :revision revision))))) + ;no revision need not to be checked, since the revision + ;is implicitely checked by the function identified-construct + (if result + result + (when error-if-nil + (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)) + "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)) + "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)) + "Returns a TopicC that is bound to the identifier-uri." + (get-item-by-identifier uri :revision revision + :identifier-type-symbol 'SubjectLocatorC + :error-if-nil error-if-nil)) + ;;; NameC (defgeneric variants (construct &key revision) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Wed Feb 24 11:04:46 2010 @@ -1360,7 +1360,7 @@ (if (= revision 0) found-topic (find-item-by-revision found-topic revision))))) - (make-instance 'TopicC :from-oid (subseq topicid 1))))) + (elephant::controller-recreate-instance elephant:*store-controller* (subseq topicid 1))))) (if (and error-if-nil (not result)) (error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision)) result)))

1 0

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

23 Feb '10

Author: lgiessmann Date: Tue Feb 23 14:49:01 2010 New Revision: 203 Log: new-datamode: added some unit-tests for TopicIdentificationC; fixed some bugs related to TopicIdentifiecationC 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 Feb 23 14:49:01 2010 @@ -773,26 +773,29 @@ (:method ((construct TopicC) (topic-identifier TopicIdentificationC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'topic-identifiers))))) - (cond ((find topic-identifier all-ids) + (map 'list #'identifier (slot-p construct 'topic-identifiers))) + (construct-to-be-merged + (let ((id-owner (identified-construct topic-identifier))) + (when (not (eql id-owner construct)) + id-owner)))) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((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))) - (all-ids - (merge-constructs (identified-construct (first all-ids) - :revision revision) - construct)) (t - (make-instance 'TopicIdAssociationC - :start-revision revision - :parent-construct construct - :identifier topic-identifier) - construct))))) + (let ((assoc + (make-instance 'TopicIdAssociationC + :parent-construct construct + :identifier topic-identifier))) + (add-to-version-history assoc :start-revision revision)))) + construct))) (defgeneric delete-topic-identifier (construct topic-identifier &key 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 Tue Feb 23 14:49:01 2010 @@ -19,12 +19,14 @@ :test-VersionedConstructC :test-ItemIdentifierC :test-PersistentIdC - :test-SubjectLocatorC)) + :test-SubjectLocatorC + :test-TopicIdentificationC)) ;;TODO: test merges-constructs when merging was caused by an item-dentifier ;;TODO: test merges-constructs when merging was caused by an psi ;;TODO: test merges-constructs when merging was caused by an subject-locator +;;TODO: test merges-constructs when merging was caused by a topic-id @@ -246,10 +248,65 @@ (is-false (locators topic-1 :revision revision-3-5))))) +(test test-TopicIdentificationC () + "Tests various functions of the TopicIdentificationC class." + (with-fixture with-empty-db (*db-dir*) + (let ((ti-1 (make-instance 'TopicIdentificationC + :uri "ti-1" + :xtm-id "xtm-id-1")) + (ti-2 (make-instance 'TopicIdentificationC + :uri "ti-2" + :xtm-id "xtm-id-2")) + (topic-1 (make-instance 'TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) + (is-false (identified-construct ti-1)) + (signals error (make-instance 'TopicIdentificationC + :uri "ti-1")) + (signals error (make-instance 'TopicIdentificationC + :xtm-id "xtm-id-1")) + (is-false (topic-identifiers topic-1)) + (add-topic-identifier topic-1 ti-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 (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)) + (is (= (length (union (list ti-1 ti-2) + (topic-identifiers topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list ti-1 ti-2) + (topic-identifiers topic-1 :revision revision-0))) + 2)) + (delete-topic-identifier topic-1 ti-1 :revision revision-3) + (is (= (length (union (list ti-2) + (topic-identifiers topic-1 :revision revision-0))) + 1)) + (is (= (length (union (list ti-1 ti-2) + (topic-identifiers topic-1 :revision revision-2))) + 2)) + (delete-topic-identifier topic-1 ti-2 :revision revision-3) + (is-false (topic-identifiers topic-1 :revision revision-3)) + (add-topic-identifier topic-1 ti-1 :revision revision-4) + (is (= (length (union (list ti-1) + (topic-identifiers topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::topic-identifiers)) 2)) + (is-false (topic-identifiers topic-1 :revision revision-3-5))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) (it.bese.fiveam:run! 'test-ItemIdentifierC) (it.bese.fiveam:run! 'test-PersistentIdC) (it.bese.fiveam:run! 'test-SubjectLocatorC) + (it.bese.fiveam:run! 'test-TopicIdentificationC) ) \ No newline at end of file

1 0

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

23 Feb '10

Author: lgiessmann Date: Tue Feb 23 14:35:31 2010 New Revision: 202 Log: new-datamode: added some unit-tests for PersistentIdC and SubjectLocatorC; fixed some bugs related to PersistentIdC, SubjectLocatorC and TopicC 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 Feb 23 14:35:31 2010 @@ -87,6 +87,8 @@ (in-package :datamodel) +;;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 @@ -287,7 +289,7 @@ (psis :associate (PersistentIdAssociationC parent-construct) :documentation "Contains all association objects that relate a topic with its actual psis.") - (locators :associate (PersistentIdAssociationC parent-construct) + (locators :associate (SubjectLocatorAssociationC parent-construct) :documentation "Contains all association objects that relate a topic with its actual subject-lcoators.") (names :associate (NameAssociationC parent-construct) @@ -824,24 +826,27 @@ (:method ((construct TopicC) (psi PersistentIdC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'psis))))) - (cond ((find psi all-ids) + (map 'list #'identifier (slot-p construct 'psis))) + (construct-to-be-merged + (let ((id-owner (identified-construct psi))) + (when (not (eql id-owner construct)) + id-owner)))) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((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))) - (all-ids - (merge-constructs (identified-construct (first all-ids) - :revision revision) - construct)) (t - (make-instance 'PersistentIdAssociationC - :start-revision revision - :parent-construct construct - :identifier psi) - construct))))) + (let ((assoc + (make-instance 'PersistentIdAssociationC + :parent-construct construct + :identifier psi))) + (add-to-version-history assoc :start-revision revision)))) + construct))) (defgeneric delete-psi (construct psi &key revision) @@ -875,24 +880,27 @@ (:method ((construct TopicC) (locator SubjectLocatorC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'locators))))) - (cond ((find locator all-ids) + (map 'list #'identifier (slot-p construct 'locators))) + (construct-to-be-merged + (let ((id-owner (identified-construct locator))) + (when (not (eql id-owner construct)) + id-owner)))) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((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))) - (all-ids - (merge-constructs (identified-construct (first all-ids) - :revision revision) - construct)) (t - (make-instance 'SubjectLocatorAssociationC - :start-revision revision - :parent-construct construct - :identifier locator) - construct))))) + (let ((assoc + (make-instance 'SubjectLocatorAssociationC + :parent-construct construct + :identifier locator))) + (add-to-version-history assoc :start-revision revision)))) + construct))) (defgeneric delete-locator (construct locator &key revision) @@ -1513,16 +1521,16 @@ (let ((id-owner (identified-construct item-identifier))) (when (not (eql id-owner construct)) id-owner)))) - (cond ((find item-identifier all-ids) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((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))) - (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - construct)) (t (let ((assoc (make-instance 'ItemIdAssociationC 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 Feb 23 14:35:31 2010 @@ -17,7 +17,15 @@ (:export :run-datamodel-tests :test-VersionInfoC :test-VersionedConstructC - :test-ItemIdentifierC)) + :test-ItemIdentifierC + :test-PersistentIdC + :test-SubjectLocatorC)) + + +;;TODO: test merges-constructs when merging was caused by an item-dentifier +;;TODO: test merges-constructs when merging was caused by an psi +;;TODO: test merges-constructs when merging was caused by an subject-locator + (declaim (optimize (debug 3))) @@ -44,9 +52,7 @@ (is (= (d::end-revision vi-1) 300)) (is (= (d::start-revision vi-2) 300)) (is (= (d::end-revision vi-2) 0)) - (is-false (d::versioned-construct-p vi-1)) - (setf (d::versioned-construct vi-1) vc) - (is-true (d::versioned-construct-p vi-1))))) + (setf (d::versioned-construct vi-1) vc)))) (test test-VersionedConstructC () @@ -78,9 +84,6 @@ (= sr-2 100) (= er-2 500))))) (d::add-to-version-history vc :start-revision 600) (is (= (length (d::versions vc)) 3)) - (map 'list #'(lambda(vi) - (is-true (d::versioned-construct-p vi))) - (d::versions vc)) (d::add-to-version-history vc :start-revision 100 :end-revision 500) @@ -95,13 +98,13 @@ (test test-ItemIdentifierC () - "Tests various functions of the VersionedCoinstructC class." + "Tests various functions of the ItemIdentifierC class." (with-fixture with-empty-db (*db-dir*) - (let ((ii-1 (make-instance 'd:ItemIdentifierC + (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) - (topic-1 (make-instance 'd:TopicC)) + (topic-1 (make-instance 'TopicC)) (revision-0 0) (revision-1 100) (revision-2 200) @@ -109,14 +112,14 @@ (revision-3-5 350) (revision-4 400)) (setf d:*TM-REVISION* revision-1) - (is-false (d:identified-construct ii-1)) - (signals error (make-instance 'd:ItemIdentifierC)) + (is-false (identified-construct ii-1)) + (signals error (make-instance 'ItemIdentifierC)) (is-false (item-identifiers topic-1)) - (d:add-item-identifier topic-1 ii-1) + (add-item-identifier topic-1 ii-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)) - (d:add-item-identifier topic-1 ii-2 :revision revision-2) + (add-item-identifier topic-1 ii-2 :revision revision-2) (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)) @@ -128,11 +131,11 @@ 2)) (delete-item-identifier topic-1 ii-1 :revision revision-3) (is (= (length (union (list ii-2) - (d:item-identifiers topic-1 + (item-identifiers topic-1 :revision revision-0))) 1)) (is (= (length (union (list ii-1 ii-2) - (d:item-identifiers topic-1 + (item-identifiers topic-1 :revision revision-2))) 2)) (delete-item-identifier topic-1 ii-2 :revision revision-3) @@ -143,10 +146,110 @@ 1)) (is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2)) (is-false (item-identifiers topic-1 :revision revision-3-5))))) - + + +(test test-PersistentIdC () + "Tests various functions of the PersistentIdC class." + (with-fixture with-empty-db (*db-dir*) + (let ((psi-1 (make-instance 'PersistentIdC + :uri "psi-1")) + (psi-2 (make-instance 'PersistentIdC + :uri "psi-2")) + (topic-1 (make-instance 'TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) + (is-false (identified-construct psi-1)) + (signals error (make-instance 'PersistentIdC)) + (is-false (psis topic-1)) + (add-psi topic-1 psi-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 (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)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-0))) + 2)) + (delete-psi topic-1 psi-1 :revision revision-3) + (is (= (length (union (list psi-2) + (psis topic-1 :revision revision-0))) + 1)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-2))) + 2)) + (delete-psi topic-1 psi-2 :revision revision-3) + (is-false (psis topic-1 :revision revision-3)) + (add-psi topic-1 psi-1 :revision revision-4) + (is (= (length (union (list psi-1) + (psis topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::psis)) 2)) + (is-false (psis topic-1 :revision revision-3-5))))) + + +(test test-SubjectLocatorC () + "Tests various functions of the SubjectLocatorC class." + (with-fixture with-empty-db (*db-dir*) + (let ((sl-1 (make-instance 'SubjectLocatorC + :uri "sl-1")) + (sl-2 (make-instance 'SubjectLocatorC + :uri "sl-2")) + (topic-1 (make-instance 'TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) + (is-false (identified-construct sl-1)) + (signals error (make-instance 'SubjectLocatorC)) + (is-false (locators topic-1)) + (add-locator topic-1 sl-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 (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)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-0))) + 2)) + (delete-locator topic-1 sl-1 :revision revision-3) + (is (= (length (union (list sl-2) + (locators topic-1 :revision revision-0))) + 1)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-2))) + 2)) + (delete-locator topic-1 sl-2 :revision revision-3) + (is-false (locators topic-1 :revision revision-3)) + (add-locator topic-1 sl-1 :revision revision-4) + (is (= (length (union (list sl-1) + (locators topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::locators)) 2)) + (is-false (locators topic-1 :revision revision-3-5))))) + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) (it.bese.fiveam:run! 'test-ItemIdentifierC) + (it.bese.fiveam:run! 'test-PersistentIdC) + (it.bese.fiveam:run! 'test-SubjectLocatorC) ) \ No newline at end of file

1 0

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

22 Feb '10

Author: lgiessmann Date: Mon Feb 22 14:55:40 2010 New Revision: 201 Log: new-datamodel: fixed some bugs in item-identifiers, add-item-identifier and delete-item-identifier; added a unit-test for item-identifiers 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 Feb 22 14:55:40 2010 @@ -1508,17 +1508,19 @@ (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'item-identifiers))))) + (map 'list #'identifier (slot-p construct 'item-identifiers))) + (construct-to-be-merged + (let ((id-owner (identified-construct item-identifier))) + (when (not (eql id-owner construct)) + id-owner)))) (cond ((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))) - (all-ids - (merge-constructs (identified-construct (first all-ids) + (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged :revision revision) construct)) (t 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 Feb 22 14:55:40 2010 @@ -97,19 +97,52 @@ (test test-ItemIdentifierC () "Tests various functions of the VersionedCoinstructC class." (with-fixture with-empty-db (*db-dir*) - (setf d:*TM-REVISION* 100) (let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) - (topic (make-instance 'd:TopicC))) + (topic-1 (make-instance 'd:TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) (is-false (d:identified-construct ii-1)) (signals error (make-instance 'd:ItemIdentifierC)) - (is-false (item-identifiers topic)) - (d:add-item-identifier topic ii-1) - (format t ">>> ~a~%" (d::parent-construct ii-1)) - (is (= (length (d:item-identifiers topic)) 1)) - ))) + (is-false (item-identifiers topic-1)) + (d:add-item-identifier topic-1 ii-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)) + (d:add-item-identifier topic-1 ii-2 :revision revision-2) + (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)) + (is (= (length (union (list ii-1 ii-2) + (item-identifiers topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list ii-1 ii-2) + (item-identifiers topic-1 :revision revision-0))) + 2)) + (delete-item-identifier topic-1 ii-1 :revision revision-3) + (is (= (length (union (list ii-2) + (d:item-identifiers topic-1 + :revision revision-0))) + 1)) + (is (= (length (union (list ii-1 ii-2) + (d:item-identifiers topic-1 + :revision revision-2))) + 2)) + (delete-item-identifier topic-1 ii-2 :revision revision-3) + (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) + (item-identifiers topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2)) + (is-false (item-identifiers topic-1 :revision revision-3-5))))) (defun run-datamodel-tests()

1 0

[isidorus-cvs] r200 - branches/new-datamodel/src/model
by Lukas Giessmann 22 Feb '10

22 Feb '10

Author: lgiessmann Date: Mon Feb 22 14:05:06 2010 New Revision: 200 Log: new-datamode: fixed a problem with elephant-associaitons in the PointerAssociationC-classes 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 Mon Feb 22 14:05:06 2010 @@ -144,29 +144,56 @@ class."))) -;;; pointers ... -(defpclass SubjectLocatorC(IdentifierC) +;;; base classes ... +(defpclass TopicMapConstructC() () - (:index t) - (:documentation "A subject-locator that contains an uri-value and an - association to SubjectLocatorAssociationC's which are in - turn associated with TopicC's.")) + (:documentation "An abstract base class for all classes that describes + Topic Maps data.")) -(defpclass PersistentIdC(IdentifierC) - () - (:index t) - (:documentation "A subject-identifier that contains an uri-value and an - association to PersistentIdAssociationC's which are in - turn associated with TopicC's.")) +(defpclass ScopableC() + ((themes :associate (ScopeAssociationC scopable-construct) + :inherit t + :documentation "Contains all association-objects that contain the + actual scope-topics.")) + (:documentation "An abstract base class for all constructs that are scoped.")) -(defpclass ItemIdentifierC(IdentifierC) - () +(defpclass TypableC() + ((instance-of :associate (TypeAssociationC type-topic) + :inherit t + :documentation "Contains all association-objects that contain + the actual type-topic.")) + (:documentation "An abstract base class for all typed constructcs.")) + + +(defpclass DatatypableC() + ((datatype :accessor datatype + :initarg :datatype + :initform constants:*xml-string* + :type string + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef).")) (:index t) - (:documentation "An item-identifier that contains an uri-value and an - association to ItemIdAssociationC's which are in turn - associated with RiefiableConstructC's.")) + (:documentation "An abstract base class for characteristics that own + an xml-datatype.")) + + +;;; pointers ... +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :inherit t + :type string + :initform (error "From PointerC(): uri must be set for a pointer") + :index t + :documentation "The actual value of a pointer, i.e. uri or ID.") + (identified-construct :associate (PointerAssociationC identifier) + :inherit t + :documentation "Associates a association-object that + additionally stores some + version-infos.")) + (:documentation "An abstract base class for all pointers.")) (defpclass IdentifierC(PointerC) @@ -187,23 +214,42 @@ representing one of them.")) -(defpclass PointerC(TopicMapConstructC) - ((uri :initarg :uri - :accessor uri - ;:inherit t - :type string - :initform (error "From PointerC(): uri must be set for a pointer") - :index t - :documentation "The actual value of a pointer, i.e. uri or ID.") - (identified-construct :associate (PointerAssociationC identifier) - :inherit t - :documentation "Associates a association-object that - additionally stores some - version-infos.")) - (:documentation "An abstract base class for all pointers.")) +(defpclass SubjectLocatorC(IdentifierC) + () + (:index t) + (:documentation "A subject-locator that contains an uri-value and an + association to SubjectLocatorAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass PersistentIdC(IdentifierC) + () + (:index t) + (:documentation "A subject-identifier that contains an uri-value and an + association to PersistentIdAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass ItemIdentifierC(IdentifierC) + () + (:index t) + (:documentation "An item-identifier that contains an uri-value and an + association to ItemIdAssociationC's which are in turn + associated with RiefiableConstructC's.")) ;;; reifiables ... +(defpclass ReifiableConstructC(TopicMapConstructC) + ((item-identifiers :associate (ItemIdAssociationC parent-construct) + :inherit t + :documentation "A relation to all item-identifiers of + this construct.") + (reifier :associate (ReifierAssociationC reified-construct) + :inherit t + :documentation "A relation to a reifier-topic.")) + (:documentation "Reifiable constructs as per TMDM.")) + + (defpclass AssociationC(ReifiableConstructC ScopableC TypableC) ((roles :associate (RoleAssociationC association) :documentation "Contains all association-objects of all roles this @@ -223,17 +269,6 @@ :documentation "Associates this object with a player-association."))) -(defpclass ReifiableConstructC(TopicMapConstructC) - ((item-identifiers :associate (ItemIdAssociationC parent-construct) - :inherit t - :documentation "A relation to all item-identifiers of - this construct.") - (reifier :associate (ReifierAssociationC reified-construct) - :inherit t - :documentation "A relation to a reifier-topic.")) - (:documentation "Reifiable constructs as per TMDM.")) - - (elephant:defpclass TopicMapC (ReifiableConstructC) ((topics :accessor topics :associate (TopicC in-topicmaps) @@ -284,6 +319,22 @@ ;;; characteristics ... +(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) + ((parent :associate (CharacteriticAssociationC characteristic) + :inherit t + :documentation "Assocates the characterist obejct with the + parent-association.") + (charvalue :initarg :charvalue + :accessor charvalue + :type string + :inherit t + :initform "" + :index t + :documentation "Contains the actual data of this object.")) + (:documentation "Scoped characteristic of a topic (meant to be used + as an abstract class).")) + + (defpclass OccurrenceC(CharacteristicC DatatypableC) () (:documentation "Represents a TM occurrence.")) @@ -300,23 +351,12 @@ (:documentation "Represents a TM variant.")) -(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) - ((parent :associate (CharacteriticAssociationC characteristic) - :inherit t - :documentation "Assocates the characterist obejct with the - parent-association.") - (charvalue :initarg :charvalue - :accessor charvalue - :type string - ;:inherit t - :initform "" - :index t - :documentation "Contains the actual data of this object.")) - (:documentation "Scoped characteristic of a topic (meant to be used - as an abstract class).")) +;;; versioned associations ... +(defpclass VersionedAssociationC(VersionedConstructC) + () + (:documentation "An abstract base class for all versioned associations.")) -;;; versioned associations ... (defpclass TypeAssociationC(VersionedAssociationC) ((type-topic :initarg :type-topic :accessor type-topic @@ -372,13 +412,19 @@ with a topic.")) -(defpclass VersionedAssociationC(VersionedConstructC) - () - (:documentation "An abstract base class for all versioned associations.")) - +;;; pointer associations ... +(defpclass PointerAssociationC (VersionedAssociationC) + ((identifier :initarg :identifier + :accessor identifier + :inherit t + :initform (error "From PointerAssociationC(): identifier must be set") + :associate PointerC + :documentation "The actual data that is associated with + the pointer-association's parent.")) + (:documentation "An abstract base class for all versioned + pointer-associations.")) -;;; pointer associations ... (defpclass SubjectLocatorAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct @@ -423,19 +469,19 @@ and reifiable-constructs.")) -(defpclass PointerAssociationC (VersionedAssociationC) - ((identifier :initarg :identifier - :accessor identifier - ;:inherit t - :initform (error "From PointerAssociationC(): identifier must be set") - :associate PointerC - :documentation "The actual data that is associated with - the pointer-association's parent.")) - (:documentation "An abstract base class for all versioned - pointer-associations.")) +;;; characteristic associations ... +(defpclass CharacteristicAssociationC(VersionedAssociationC) + ((characteristic :initarg :characteristic + :accessor characteristic + :inherit t + :initform (error "From CharacteristicCAssociation(): characteristic must be set") + :associate CharactersiticC + :documentation "Associates this object with the actual + characteristic object.")) + (:documentation "An abstract base class for all association-objects that + associates characteristics with topics.")) -;;; characteristic associations ... (defpclass VariantAssociationC(CharateristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct @@ -466,18 +512,6 @@ Additionally version-infos are stored.")) -(defpclass CharacteristicAssociationC(VersionedAssociationC) - ((characteristic :initarg :characteristic - :accessor characteristic - ;:inherit t - :initform (error "From CharacteristicCAssociation(): characteristic must be set") - :associate CharactersiticC - :documentation "Associates this object with the actual - characteristic object.")) - (:documentation "An abstract base class for all association-objects that - associates characteristics with topics.")) - - ;;; roles/association associations ... (defpclass PlayerAssociationC(VersionedAssociationC) ((player-topic :initarg :player-topic @@ -511,48 +545,19 @@ version-infos between these realtions.")) -;;; base classes ... -(defpclass TopicMapConstructC() - () - (:documentation "An abstract base class for all classes that describes - Topic Maps data.")) - - -(defpclass ScopableC() - ((themes :associate (ScopeAssociationC scopable-construct) - :inherit t - :documentation "Contains all association-objects that contain the - actual scope-topics.")) - (:documentation "An abstract base class for all constructs that are scoped.")) - - -(defpclass TypableC() - ((instance-of :associate (TypeAssociationC type-topic) - :inherit t - :documentation "Contains all association-objects that contain - the actual type-topic.")) - (:documentation "An abstract base class for all typed constructcs.")) - - -(defpclass DatatypableC() - ((datatype :accessor datatype - :initarg :datatype - :initform constants:*xml-string* - :type string - :documentation "The XML Schema datatype of the occurrencevalue - (optional, always IRI for resourceRef).")) - (:index t) - (:documentation "An abstract base class for characteristics that own - an xml-datatype.")) - - ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun slot-p (instance slot-symbol) "Returns t if the slot depending on slot-symbol is bound and not nil." - (when (slot-boundp instance slot-symbol) - (let ((value (slot-value instance slot-symbol))) - (when value - value)))) + (if (slot-boundp instance slot-symbol) + (let ((value (slot-value instance slot-symbol))) + (when value + value)) + ;elephant-relations are handled separately, since slot-boundp does not + ;here + (handler-case (let ((value (slot-value instance slot-symbol))) + (when value + value)) + (error () nil)))) (defun delete-1-n-association(instance slot-symbol) @@ -1517,10 +1522,11 @@ :revision revision) construct)) (t - (make-instance 'ItemIdAssociationC - :start-revision revision - :parent-construct construct - :identifier item-identifier))) + (let ((assoc + (make-instance 'ItemIdAssociationC + :parent-construct construct + :identifier item-identifier))) + (add-to-version-history assoc :start-revision revision)))) construct)))

1 0

[isidorus-cvs] r199 - in branches/new-datamodel: playground src/model
by Lukas Giessmann 21 Feb '10

21 Feb '10

Author: lgiessmann Date: Sun Feb 21 15:34:01 2010 New Revision: 199 Log: new-datamodel: added some example code files that analyses certain situations and elephant's behviour Added: branches/new-datamodel/playground/ branches/new-datamodel/playground/ii_versioned_association.lisp branches/new-datamodel/playground/system_crash.lisp branches/new-datamodel/playground/versioned-pointer.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp Added: branches/new-datamodel/playground/ii_versioned_association.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/ii_versioned_association.lisp Sun Feb 21 15:34:01 2010 @@ -0,0 +1,117 @@ +(asdf:operate 'asdf:load-op 'elephant) +(use-package :elephant) + +(defpclass VersionInfoC() + ((start-revision :initarg :start-revision + :accessor start-revision + :type integer + :initform 0) + (end-revision :initarg :end-revision + :accessor end-revision + :type integer + :initform 0) + (versioned-construct :initarg :versioned-construct + :accessor versioned-construct + :associate VersionedConstructC))) + +(defpclass VersionedConstructC() + ((versions :initarg :versions + :accessor versions + :inherit t + :associate (VersionInfoC versioned-construct)))) + + +(defpclass VersionedAssociationC(VersionedConstructC) + ()) + + +(defpclass PointerAssociationC (VersionedAssociationC) + ((identifier :initarg :identifier + :accessor identifier + :inherit t + :initform (error "From PointerAssociationC(): identifier must be set") + :associate PointerC))) + + +(defpclass ItemIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From ItemIdAssociationC(): parent-construct must be set") + :associate ReifiableConstructC))) + + +(defpclass TopicMapConstructC() + ()) + + +(defpclass ReifiableConstructC(TopicMapConstructC) + ((item-identifiers :associate (ItemIdAssociationC parent-construct) + :inherit t))) + + +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :inherit t + :type string + :initform (error "From PointerC(): uri must be set for a pointer") + :index t) + (identified-construct :associate (PointerAssociationC identifier) + :inherit t))) + + +(defpclass IdentifierC(PointerC) + ()) + + +(defpclass ItemIdentifierC(IdentifierC) + () + (:index t)) + + +(open-store '(:BDB "data_base")) +(defvar *p* (make-instance 'PointerC + :uri "anyUri")) +(defvar *pa* (make-instance 'PointerAssociationC + :identifier *p*)) + +(defvar *ii* (make-instance 'ItemIdentifierC + :uri "anyUri")) + +(defvar *pa-ii* (make-instance 'PointerAssociationC + :identifier *ii*)) + +(defvar *ii-2* (make-instance 'ItemIdentifierC + :uri "anyUri")) + +(defvar *rc* (make-instance 'ReifiableConstructC)) + + +(defvar *ia* (make-instance 'ItemIdAssociationC + :identifier *ii-2* + :parent-construct *rc*)) + + +(when (not (slot-value *p* 'identified-construct)) + (error ">> 1")) + +(when (not (slot-value *pa* 'identifier)) + (error ">> 2")) + +(when (not (slot-value *ii* 'identified-construct)) + (error ">> 3")) + +(when (not (slot-value *pa-ii* 'identifier)) + (error ">> 4")) + +(when (not (slot-value *ii-2* 'identified-construct)) + (error ">> 5")) + +(when (not (slot-value *rc* 'item-identifiers)) + (error ">> 6")) + +(when (not (slot-value *ia* 'parent-construct)) + (error ">> 7")) + +(when (not (slot-value *ia* 'identifier)) + (error ">> 8")) \ No newline at end of file Added: branches/new-datamodel/playground/system_crash.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/system_crash.lisp Sun Feb 21 15:34:01 2010 @@ -0,0 +1,3 @@ +(sb-mop:class-slots (find-class 'd:ItemIdentifierC)) +(sb-mop:class-finalized-p (find-class 'd:ItemIdentifierC)) +(sb-mop:finalize-inheritance (find-class 'd:ItemIdentifierC)) Added: branches/new-datamodel/playground/versioned-pointer.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/versioned-pointer.lisp Sun Feb 21 15:34:01 2010 @@ -0,0 +1,28 @@ +(asdf:operate 'asdf:load-op 'elephant) +(elephant:open-store '(:BDB "data_base")) +(defpclass Relation() + ((to-a :associate NodeA + :accessor to-a + :initarg :to-a) + (to-b :associate NodeB + :accessor to-b + :initarg :to-b) + (version :initarg :version + :accessor version + :type integer + :index t)) + (:index t)) +(defpclass NodeA() + ((relation-to-b :associate (Relation to-a) + :accessor relation-to-b + :initarg :relation-to-b)) + (:index t)) +(defpclass NodeB() + ((relation-to-a :associate (Relation to-b) + :accessor relation-to-a + :initarg :relation-to-a)) + (:index t)) +(defvar *rel* (make-instance 'Relation + :to-a (make-instance 'NodeA) + :to-b (make-instance 'NodeB) + :version 1)) Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Feb 21 15:34:01 2010 @@ -190,7 +190,7 @@ (defpclass PointerC(TopicMapConstructC) ((uri :initarg :uri :accessor uri - :inherit t + ;:inherit t :type string :initform (error "From PointerC(): uri must be set for a pointer") :index t @@ -308,7 +308,7 @@ (charvalue :initarg :charvalue :accessor charvalue :type string - :inherit t + ;:inherit t :initform "" :index t :documentation "Contains the actual data of this object.")) @@ -426,7 +426,7 @@ (defpclass PointerAssociationC (VersionedAssociationC) ((identifier :initarg :identifier :accessor identifier - :inherit t + ;:inherit t :initform (error "From PointerAssociationC(): identifier must be set") :associate PointerC :documentation "The actual data that is associated with @@ -469,7 +469,7 @@ (defpclass CharacteristicAssociationC(VersionedAssociationC) ((characteristic :initarg :characteristic :accessor characteristic - :inherit t + ;:inherit t :initform (error "From CharacteristicCAssociation(): characteristic must be set") :associate CharactersiticC :documentation "Associates this object with the actual

1 0

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

20 Feb '10

Author: lgiessmann Date: Sat Feb 20 09:49:30 2010 New Revision: 198 Log: new-datamodel: fixed some accessor/slot-names; restructured the file datamodel.lisp 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 Feb 20 09:49:30 2010 @@ -78,9 +78,11 @@ :mark-as-deleted-p :in-topicmaps :delete-construct + :get-revision ;;globals - :*TM-REVISION*)) + :*TM-REVISION* + :*CURRENT-XTM*)) (in-package :datamodel) @@ -89,7 +91,7 @@ ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done ;;TODO: use some exceptions --> more than one type, -;; identifier, not-mergable merges, ... +;; identifier, not-mergable merges, missing-init-args... ;;TODO: implement make-construct -> symbol ;; replace the latest make-construct-method ;;TODO: implement merge-construct -> ReifiableConstructC -> ... @@ -103,6 +105,447 @@ (defvar *TM-REVISION* 0) +(defparameter *CURRENT-XTM* nil "Represents the currently active TM.") + + +;;; classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; versioning +(defpclass VersionInfoC() + ((start-revision :initarg :start-revision + :accessor start-revision + :type integer + :initform 0 + :documentation "The start-revision of the version's + interval of a versioned object.") + (end-revision :initarg :end-revision + :accessor end-revision + :type integer + :initform 0 + :documentation "The end-revision of the version's interval + of a versioned object.") + (versioned-construct :initarg :versioned-construct + :accessor versioned-construct + :associate VersionedConstructC + :documentation "The reference of the versioned + object that is described by this + VersionInfoC-object.")) + (:documentation "A VersionInfoC-object describes the revision information + of a versioned object in intervals starting by the value + start-revision and ending by the value end-revision - 1. + end-revision=0 means always the latest version.")) + + +(defpclass VersionedConstructC() + ((versions :initarg :versions + :accessor versions + :inherit t + :associate (VersionInfoC versioned-construct) + :documentation "Version infos for former versions of this base + class."))) + + +;;; pointers ... +(defpclass SubjectLocatorC(IdentifierC) + () + (:index t) + (:documentation "A subject-locator that contains an uri-value and an + association to SubjectLocatorAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass PersistentIdC(IdentifierC) + () + (:index t) + (:documentation "A subject-identifier that contains an uri-value and an + association to PersistentIdAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass ItemIdentifierC(IdentifierC) + () + (:index t) + (:documentation "An item-identifier that contains an uri-value and an + association to ItemIdAssociationC's which are in turn + associated with RiefiableConstructC's.")) + + +(defpclass IdentifierC(PointerC) + () + (:documentation "An abstract base class for all TM-Identifiers.")) + + +(defpclass TopicIdentificationC(PointerC) + ((xtm-id :initarg :xtm-id + :accessor xtm-id + :type string + :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier") + :index t + :documentation "ID of the TM this identification came from.")) + (:index t) + (:documentation "Identify topic items through generalized topic-ids. + A topic may have many original topicids, the class + representing one of them.")) + + +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :inherit t + :type string + :initform (error "From PointerC(): uri must be set for a pointer") + :index t + :documentation "The actual value of a pointer, i.e. uri or ID.") + (identified-construct :associate (PointerAssociationC identifier) + :inherit t + :documentation "Associates a association-object that + additionally stores some + version-infos.")) + (:documentation "An abstract base class for all pointers.")) + + +;;; reifiables ... +(defpclass AssociationC(ReifiableConstructC ScopableC TypableC) + ((roles :associate (RoleAssociationC association) + :documentation "Contains all association-objects of all roles this + association contains.") + (in-topicmaps :associate (TopicMapC associations) + :many-to-many t + :documentation "List of all topic maps this association is + part of")) + (:index t) + (:documentation "Association in a Topic Map")) + + +(defpclass RoleC(ReifiableConstructC TypableC) + ((parent :associate (RoleAssociationC role) + :documentation "Associates this object with a role-association.") + (player :associate (PlayerAssociationC parent-construct) + :documentation "Associates this object with a player-association."))) + + +(defpclass ReifiableConstructC(TopicMapConstructC) + ((item-identifiers :associate (ItemIdAssociationC parent-construct) + :inherit t + :documentation "A relation to all item-identifiers of + this construct.") + (reifier :associate (ReifierAssociationC reified-construct) + :inherit t + :documentation "A relation to a reifier-topic.")) + (:documentation "Reifiable constructs as per TMDM.")) + + +(elephant:defpclass TopicMapC (ReifiableConstructC) + ((topics :accessor topics + :associate (TopicC in-topicmaps) + :documentation "List of topics that explicitly belong to this TM.") + (associations :accessor associations + :associate (AssociationC in-topicmaps) + :documentation "List of associations that belong to this TM.")) + (:documentation "Represnets a topic map.")) + + +(defpclass TopicC (ReifiableConstructC) + ((topic-identifiers :associate (TopicIdAssociationC parent-construct) + :documentation "Contains all association objects that + relate a topic with its actual + topic-identifiers.") + (psis :associate (PersistentIdAssociationC parent-construct) + :documentation "Contains all association objects that relate a topic + with its actual psis.") + (locators :associate (PersistentIdAssociationC parent-construct) + :documentation "Contains all association objects that relate a + topic with its actual subject-lcoators.") + (names :associate (NameAssociationC parent-construct) + :documentation "Contains all association objects that relate a topic + with its actual names.") + (occurrences :associate (OccurrenceAssociationC parent-construct) + :documentation "Contains all association objects that relate a + topic with its actual occurrences.") + (player-in-roles :associate (PlayerAssociationC player-topic) + :documentation "Contains all association objects that relate + a topic that is a player with its role.") + (used-as-type :associate (TypeAssociationC type-topic) + :documentation "Contains all association objects that relate a + topic that is a type with its typable obejct.") + (used-as-theme :associate (ScopeAssociationC theme-topic) + :documentation "Contains all association objects that relate a + topic that is a theme with its scoppable + object.") + (reified-construct :associate (ReifiedAssociationC reifier-topic) + :documentation "Contains all association objects that + relate a topic that is a reifier with + its reified object.") + (in-topicmaps :associate (TopicMapC topics) + :many-to-many t + :documentation "List of all topic maps this topic is part of.")) + (:index t) + (:documentation "Represents a TM topic.")) + + + +;;; characteristics ... +(defpclass OccurrenceC(CharacteristicC DatatypableC) + () + (:documentation "Represents a TM occurrence.")) + + +(defpclass NameC(CharacteristicC) + ((variants :associate (VariantAssociationC parent-construct) + :documentation "Associates this obejct with varian-associations.")) + (:documentation "Scoped name of a topic.")) + + +(defpclass VariantC(CharacteristicC DatatypableC) + () + (:documentation "Represents a TM variant.")) + + +(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) + ((parent :associate (CharacteriticAssociationC characteristic) + :inherit t + :documentation "Assocates the characterist obejct with the + parent-association.") + (charvalue :initarg :charvalue + :accessor charvalue + :type string + :inherit t + :initform "" + :index t + :documentation "Contains the actual data of this object.")) + (:documentation "Scoped characteristic of a topic (meant to be used + as an abstract class).")) + + +;;; versioned associations ... +(defpclass TypeAssociationC(VersionedAssociationC) + ((type-topic :initarg :type-topic + :accessor type-topic + :initform (error "From TypeAssociationC(): type-topic must be set") + :associate TopicC + :documentation "Associates this object with a topic that is used + as type.") + (typable-construct :initarg :typable-construct + :accessor typable-construct + :initform (error "From TypeAssociationC(): typable-construct must be set") + :associate TypableC + :documentation "Associates this object with the typable + construct that is typed by the + type-topic.")) + (:documentation "This class associates topics that are used as type for + typable constructcs. Additionally there are stored some + version-infos.")) + + +(defpclass ScopeAssociationC(VersionedAssociationC) + ((theme-topic :initarg :theme-topic + :accessor theme-topic + :initform (error "From ScopeAssociationC(): theme-topic must be set") + :associate TopicC + :documentation "Associates this opbject with a topic that is a + scopable construct.") + (scopable-construct :initarg :scopable-construct + :accessor scopable-construct + :initform (error "From ScopeAssociationC(): scopable-construct must be set") + :associate ScopableC + :documentation "Associates this object with the socpable + construct that is scoped by the + scope-topic.")) + (:documentation "This class associates topics that are used as scope with + scopable construtcs. Additionally there are stored some + version-infos")) + + +(defpclass ReifierAssociationC(VersionedAssociationC) + ((reifiable-construct :initarg :reifiable-construct + :accessor reifiable-construct + :initform (error "From ReifierAssociation(): reifiable-construct must be set") + :associate ReifiableConstructC + :documentation "The actual construct which is reified + by a topic.") + (reifier-topic :initarg :reifier-topic + :accessor reifier-topic + :initform (error "From ReifierAssociationC(): reifier-topic must be set") + :associate TopicC + :documentation "The reifier-topic that reifies the + reifiable-construct.")) + (:documentation "A versioned-association that relates a reifiable-construct + with a topic.")) + + +(defpclass VersionedAssociationC(VersionedConstructC) + () + (:documentation "An abstract base class for all versioned associations.")) + + + +;;; pointer associations ... +(defpclass SubjectLocatorAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "The actual topic which is associated + with the subject-locator.")) + (:documentation "A pointer that associates subject-locators, versions + and topics.")) + + +(defpclass PersistentIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From PersistentIdAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "The actual topic which is associated + with the subject-identifier/psi.")) + (:documentation "A pointer that associates subject-identifiers, versions + and topics.")) + + +(defpclass TopicIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From TopicIdAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "The actual topic which is associated + with the topic-identifier.")) + (:documentation "A pointer that associates topic-identifiers, versions + and topics.")) + + +(defpclass ItemIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From ItemIdAssociationC(): parent-construct must be set") + :associate ReifiableConstructC + :documentation "The actual parent which is associated + with the item-identifier.")) + (:documentation "A pointer that associates item-identifiers, versions + and reifiable-constructs.")) + + +(defpclass PointerAssociationC (VersionedAssociationC) + ((identifier :initarg :identifier + :accessor identifier + :inherit t + :initform (error "From PointerAssociationC(): identifier must be set") + :associate PointerC + :documentation "The actual data that is associated with + the pointer-association's parent.")) + (:documentation "An abstract base class for all versioned + pointer-associations.")) + + +;;; characteristic associations ... +(defpclass VariantAssociationC(CharateristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From VariantAssociationC(): parent-construct must be set") + :associate NameC + :documentation "Associates this object with a name.")) + (:documentation "Associates variant objects with name obejcts. + Additionally version-infos are stored.")) + + +(defpclass NameAssociationC(CharacteristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From NameAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "Associates this object with a topic.")) + (:documentation "Associates name objects with their parent topics. + Additionally version-infos are stored.")) + + +(defpclass OccurrenceAssociationC(CharacteristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From OccurrenceAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "Associates this object with a topic.")) + (:documentation "Associates occurrence objects with their parent topics. + Additionally version-infos are stored.")) + + +(defpclass CharacteristicAssociationC(VersionedAssociationC) + ((characteristic :initarg :characteristic + :accessor characteristic + :inherit t + :initform (error "From CharacteristicCAssociation(): characteristic must be set") + :associate CharactersiticC + :documentation "Associates this object with the actual + characteristic object.")) + (:documentation "An abstract base class for all association-objects that + associates characteristics with topics.")) + + +;;; roles/association associations ... +(defpclass PlayerAssociationC(VersionedAssociationC) + ((player-topic :initarg :player-topic + :accessor player-topic + :associate TopicC + :initform (error "From PlayerAssociationC(): player-topic must be set") + :documentation "Associates this object with a topic that is + a player.") + (parent-construct :initarg :parent-construct + :accessor parent-construct + :associate RoleC + :initform (error "From PlayerAssociationC(): parent-construct must be set") + :documentation "Associates this object with the parent-association.")) + (:documentation "This class associates roles and their player in given + revisions.")) + + +(defpclass RoleAssociationC(VersionedAssociationC) + ((role :initarg :role + :accessor role + :associate RoleC + :initform (error "From RoleAssociationC(): role must be set") + :documentation "Associates this objetc with a role-object.") + (parent-construct :initarg :parent-construct + :accessor parent-construct + :associate AssociationC + :initform (error "From RoleAssociationC(): parent-construct must be set") + :documentation "Assocates thius object with an + association-object.")) + (:documentation "Associates roles with assoications and adds some + version-infos between these realtions.")) + + +;;; base classes ... +(defpclass TopicMapConstructC() + () + (:documentation "An abstract base class for all classes that describes + Topic Maps data.")) + + +(defpclass ScopableC() + ((themes :associate (ScopeAssociationC scopable-construct) + :inherit t + :documentation "Contains all association-objects that contain the + actual scope-topics.")) + (:documentation "An abstract base class for all constructs that are scoped.")) + + +(defpclass TypableC() + ((instance-of :associate (TypeAssociationC type-topic) + :inherit t + :documentation "Contains all association-objects that contain + the actual type-topic.")) + (:documentation "An abstract base class for all typed constructcs.")) + + +(defpclass DatatypableC() + ((datatype :accessor datatype + :initarg :datatype + :initform constants:*xml-string* + :type string + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef).")) + (:index t) + (:documentation "An abstract base class for characteristics that own + an xml-datatype.")) + + ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun slot-p (instance slot-symbol) "Returns t if the slot depending on slot-symbol is bound and not nil." @@ -154,46 +597,18 @@ properties)))))) -;;; VersionInfoC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass VersionInfoC() - ((start-revision :initarg :start-revision - :accessor start-revision - :type integer - :initform 0 - :documentation "The start-revision of the version's - interval of a versioned object.") - (end-revision :initarg :end-revision - :accessor end-revision - :type integer - :initform 0 - :documentation "The end-revision of the version's interval - of a versioned object.") - (versioned-construct :initarg :versioned-construct - :accessor versioned-construct - :associate VersionedConstructC - :documentation "The reference of the versioned - object that is described by this - VersionInfoC-object.")) - (:documentation "A VersionInfoC-object describes the revision information - of a versioned object in intervals starting by the value - start-revision and ending by the value end-revision - 1. - end-revision=0 means always the latest version.")) +(defun get-revision () + "TODO: replace by something that does not suffer from a 1 second resolution." + (get-universal-time)) +;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; VersionInfocC (defmethod delete-construct :before ((version-info VersionInfoC)) (delete-1-n-association version-info 'versioned-construct)) -;;; VersionedConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass VersionedConstructC() - ((versions :initarg :versions - :accessor versions - :inherit t - :associate (VersionInfoC versioned-construct) - :documentation "Version infos for former versions of this base - class."))) - - +;;; VersionedConstructC (defmethod delete-construct :before ((construct VersionedConstructC)) (dolist (version-info (versions construct)) (delete-construct version-info))) @@ -303,80 +718,7 @@ (setf (end-revision last-version) revision)))) -;;; TopicMapC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(elephant:defpclass TopicMapC (ReifiableConstructC) - ((topics :accessor topics - :associate (TopicC in-topicmaps) - :documentation "List of topics that explicitly belong to this TM.") - (associations :accessor associations - :associate (AssociationC in-topicmaps) - :documentation "List of associations that belong to this TM.")) - (:documentation "Represnets a topic map.")) - - -;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; SubjectLocatorC -;;; PersistentIdC -;;; ItemIdentifierC -;;; IdentifierC -;;; TopicIdentificationC ;;; PointerC -(defpclass SubjectLocatorC(IdentifierC) - () - (:index t) - (:documentation "A subject-locator that contains an uri-value and an - association to SubjectLocatorAssociationC's which are in - turn associated with TopicC's.")) - - -(defpclass PersistentIdC(IdentifierC) - () - (:index t) - (:documentation "A subject-identifier that contains an uri-value and an - association to PersistentIdAssociationC's which are in - turn associated with TopicC's.")) - - -(defpclass ItemIdentifierC(IdentifierC) - () - (:index t) - (:documentation "An item-identifier that contains an uri-value and an - association to ItemIdAssociationC's which are in turn - associated with RiefiableConstructC's.")) - - -(defpclass IdentifierC(PointerC) - () - (:documentation "An abstract base class for all TM-Identifiers.")) - - -(defpclass TopicIdentificationC(PointerC) - ((xtm-id :initarg :xtm-id - :accessor xtm-id - :type string - :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier") - :index t - :documentation "ID of the TM this identification came from.")) - (:index t) - (:documentation "Identify topic items through generalized topic-ids. - A topic may have many original topicids, the class - representing one of them.")) - - -(defpclass PointerC(TopicMapConstructC) - ((uri :initarg :uri - :accessor uri - :inherit t - :type string - :initform (error "From PointerC(): uri must be set for a pointer") - :index t - :documentation "The actual value of a pointer, i.e. uri or ID.") - (identified-construct :initarg :identified-construct - :associate (PointerAssociationC identifier) - :inherit t)) - (:documentation "An abstract base class for all pointers.")) - - (defgeneric identified-construct (construct &key revision) (:documentation "Returns the identified-construct -> ReifiableConstructC or TopicC that corresponds with the passed revision.") @@ -389,77 +731,7 @@ (first assocs))))) -;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass TopicC (ReifiableConstructC) - ((topic-identifiers :associate (TopicIdAssociationC parent-construct) - :documentation "Contains all association objects that - relate a topic with its actual - topic-identifiers.") - (psis :associate (PersistentIdAssociationC parent-construct) - :documentation "Contains all association objects that relate a topic - with its actual psis.") - (locators :associate (PersistentIdAssociationC parent-construct) - :documentation "Contains all association objects that relate a - topic with its actual subject-lcoators.") - (names :associate (NameAssociationC parent-construct) - :documentation "Contains all association objects that relate a topic - with its actual names.") - (occurrences :associate (OccurrenceAssociationC parent-construct) - :documentation "Contains all association objects that relate a - topic with its actual occurrences.") - (player-in-roles :associate (PlayerAssociationC player-topic) - :documentation "Contains all association objects that relate - a topic that is a player with its role.") - (used-as-type :associate (TypeAssociationC type-topic) - :documentation "Contains all association objects that relate a - topic that is a type with its typable obejct.") - (used-as-theme :associate (ScopeAssociationC theme-topic) - :documentation "Contains all association objects that relate a - topic that is a theme with its scoppable - object.") - (reified-construct :associate (ReifiedAssociationC reifier-topic) - :documentation "Contains all association objects that - relate a topic that is a reifier with - its reified object.") - (in-topicmaps :associate (TopicMapC topics) - :many-to-many t - :documentation "List of all topic maps this topic is part of.")) - (:index t) - (:documentation "Represents a TM topic.")) - - -(defpclass OccurrenceC(CharacteristicC DatatypableC) - () - (:documentation "Represents a TM occurrence.")) - - -(defpclass NameC(CharacteristicC) - ((variants :associate (VariantAssociationC parent-construct) - :documentation "Associates this obejct with varian-associations.")) - (:documentation "Scoped name of a topic.")) - - -(defpclass VariantC(CharacteristicC DatatypableC) - () - (:documentation "Represents a TM variant.")) - - -(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) - ((parent :associate (CharacteriticAssociationC characteristic) - :inherit t - :documentation "Assocates the characterist obejct with the - parent-association.") - (charvalue :initarg :charvalue - :accessor charvalue - :type string - :inherit t - :initform "" - :index t - :documentation "Contains the actual data of this object.")) - (:documentation "Scoped characteristic of a topic (meant to be used - as an abstract class).")) - - +;;; TopicC (defmethod delete-construct :before ((construct TopicC)) "Deletes all association objects of the passed construct." (dolist (assoc (append (slot-p construct 'topic-identifiers) @@ -509,10 +781,10 @@ :revision revision) construct)) (t - (make-construct 'TopicIdAssociationC - :start-revision revision - :parent-construct construct - :identifier topic-identifier) + (make-instance 'TopicIdAssociationC + :start-revision revision + :parent-construct construct + :identifier topic-identifier) construct))))) @@ -560,10 +832,10 @@ :revision revision) construct)) (t - (make-construct 'PersistentIdAssociationC - :start-revision revision - :parent-construct construct - :identifier psi) + (make-instance 'PersistentIdAssociationC + :start-revision revision + :parent-construct construct + :identifier psi) construct))))) @@ -611,10 +883,10 @@ :revision revision) construct)) (t - (make-construct 'SubjectLocatorAssociationC - :start-revision revision - :parent-construct construct - :identifier locator) + (make-instance 'SubjectLocatorAssociationC + :start-revision revision + :parent-construct construct + :identifier locator) construct))))) @@ -660,10 +932,10 @@ when (eql (parent-construct name-assoc) name) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) - (make-construct 'NameAssociationC - :start-revision revision - :parent-construct construct - :characteristic name)) + (make-instance 'NameAssociationC + :start-revision revision + :parent-construct construct + :characteristic name)) construct))) @@ -709,10 +981,10 @@ when (eql (parent-construct occ-assoc) occurrence) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) - (make-construct 'OccurrenceAssociationC - :start-revision revision - :parent-construct construct - :characteristic occurrence)) + (make-instance 'OccurrenceAssociationC + :start-revision revision + :parent-construct construct + :characteristic occurrence)) construct))) @@ -773,6 +1045,8 @@ (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) + +;;; NameC (defgeneric variants (construct &key revision) (:documentation "Returns all variants that correspond with the given revision and that are associated with the passed construct.") @@ -786,7 +1060,7 @@ (defgeneric add-variant (construct variant &key revision) (:documentation "Adds the given theme-topic to the passed scopable-construct.") - (:method ((construct ScopableC) (variant VariantC) + (:method ((construct NameC) (variant VariantC) &key (revision *TM-REVISION*)) (when (not (eql (parent variant) construct)) (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" @@ -822,6 +1096,7 @@ construct))) +;;; CharacteristicC (defmethod delete-construct :before ((construct CharacteristicC)) "Deletes all association-obejcts." (dolist (parent-assoc (slot-p construct 'parent)) @@ -923,66 +1198,20 @@ (let ((assoc-to-delete (loop for parent-assoc in (slot-p construct 'parent) when (eql (characteristic parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct)) - - -;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; PlayerAssociationC -;;; RoleAssociationC -;;; VariantAssociationC -;;; NameAssociationC -;;; OccurrenceAssociationC -;;; CharacteristicAssociationC -;;; TypeAssociationC -;;; ScopeAssociationC -;;; ReifierAssociationC -;;; SubjectLocatorAssociationC -;;; PersistentIdAssociationC -;;; TopicIdAssociationC -;;; ItemIdAssociationC -;;; PointerAssociationC -;;; VersionedAssociationC -(defpclass PlayerAssociationC(VersionedAssociationC) - ((player-topic :initarg :player-topic - :accessor player-topic - :associate TopicC - :initform (error "From PlayerAssociationC(): player-topic must be set") - :documentation "Associates this object with a topic that is - a player.") - (parent-construct :initarg :parent-construct - :accessor parent-construct - :associate RoleC - :initform (error "From PlayerAssociationC(): parent-construct must be set") - :documentation "Associates this object with the parent-association.")) - (:documentation "This class associates roles and their player in given - revisions.")) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct)) +;;; PlayerAssociationC (defmethod delete-construct :before ((construct PlayerAssociationC)) "Deletes all elephant-associations." (delete-1-n-association construct 'player-topic) (delete-1-n-association construct 'parent-construct)) -(defpclass RoleAssociationC(VersionedAssociationC) - ((role :initarg :role - :accessor role - :associate RoleC - :initform (error "From RoleAssociationC(): role must be set") - :documentation "Associates this objetc with a role-object.") - (parent-construct :initarg :parent-construct - :accessor parent-construct - :associate AssociationC - :initform (error "From RoleAssociationC(): parent-construct must be set") - :documentation "Assocates thius object with an - association-object.")) - (:documentation "Associates roles with assoications and adds some - version-infos between these realtions.")) - - +;;; RoleAssociationC (defmethod delete-construct :before ((construct RoleAssociationC)) "Deletes all elephant-associations and the entire role if it is not associated with another AssociationC object." @@ -993,60 +1222,22 @@ (delete-1-n-association construct 'parent-construct))) -(defpclass VariantAssociationC(CharateristicAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From VariantAssociationC(): parent-construct must be set") - :associate NameC - :documentation "Associates this object with a name.")) - (:documentation "Associates variant objects with name obejcts. - Additionally version-infos are stored.")) - - +;;; VariantAssociationC (defmethod delete-construct :before ((construct VariantAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass NameAssociationC(CharacteristicAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From NameAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "Associates this object with a topic.")) - (:documentation "Associates name objects with their parent topics. - Additionally version-infos are stored.")) - - +;;; NameAssociationC (defmethod delete-construct :before ((construct NameAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass OccurrenceAssociationC(CharacteristicAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From OccurrenceAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "Associates this object with a topic.")) - (:documentation "Associates occurrence objects with their parent topics. - Additionally version-infos are stored.")) - - +;;; OccurrenceAssociationC (defmethod delete-construct :before ((construct OccurrenceAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass CharacteristicAssociationC(VersionedAssociationC) - ((characteristic :initarg :characteristic - :accessor characteristic - :inherit t - :initform (error "From CharacteristicCAssociation(): characteristic must be set") - :associate CharactersiticC - :documentation "Associates this object with the actual - characteristic object.")) - (:documentation "An abstract base class for all association-objects that - associates characteristics with topics.")) - - +;;; CharacteristicAssociationC (defmethod delete-construct :before ((construct CharacteristicAssociationC)) "Deletes all elephant-associations." (let ((characteristic (characteristic construct))) @@ -1056,73 +1247,21 @@ (delete-construct characteristic)))) -(defpclass TypeAssociationC(VersionedAssociationC) - ((type-topic :initarg :type-topic - :accessor type-topic - :initform (error "From TypeAssociationC(): type-topic must be set") - :associate TopicC - :documentation "Associates this object with a topic that is used - as type.") - (typable-construct :initarg :typable-construct - :accessor typable-construct - :initform (error "From TypeAssociationC(): typable-construct must be set") - :associate TypableC - :documentation "Associates this object with the typable - construct that is typed by the - type-topic.")) - (:documentation "This class associates topics that are used as type for - typable constructcs. Additionally there are stored some - version-infos.")) - - +;;; TypeAssociationC (defmethod delete-construct :before ((construct TypeAssociationC)) "Deletes all elephant-associations of the given construct." (delete-1-n-association construct 'type-topic) (delete-1-n-association construct 'typable-construct)) -(defpclass ScopeAssociationC(VersionedAssociationC) - ((theme-topic :initarg :theme-topic - :accessor theme-topic - :initform (error "From ScopeAssociationC(): theme-topic must be set") - :associate TopicC - :documentation "Associates this opbject with a topic that is a - scopable construct.") - (scopable-construct :initarg :scopable-construct - :accessor scopable-construct - :initform (error "From ScopeAssociationC(): scopable-construct must be set") - :associate ScopableC - :documentation "Associates this object with the socpable - construct that is scoped by the - scope-topic.")) - (:documentation "This class associates topics that are used as scope with - scopable construtcs. Additionally there are stored some - version-infos")) - - +;;; ScopeAssociationC (defmethod delete-construct :before ((construct ScopeAssociationC)) "Deletes all elephant-associations of this construct." (delete-1-n-association construct 'theme-topic) (delete-1-n-association construct 'scopable-topic)) -(defpclass ReifierAssociationC(VersionedAssociationC) - ((reifiable-construct :initarg :reifiable-construct - :accessor reifiable-construct - :initform (error "From ReifierAssociation(): reifiable-construct must be set") - :associate ReifiableConstructC - :documentation "The actual construct which is reified - by a topic.") - (reifier-topic :initarg :reifier-topic - :accessor reifier-topic - :initform (error "From ReifierAssociationC(): reifier-topic must be set") - :associate TopicC - :documentation "The reifier-topic that reifies the - reifiable-construct.")) - (:documentation "A versioned-association that relates a reifiable-construct - with a topic.")) - - +;;; ReifierAssociationC (defmethod delete-construct :before ((construct ReifierAssociationC)) "Deletes the association-construct and the reifier-topic when it is not used as a reifier of another construct." @@ -1133,78 +1272,27 @@ (delete-construct reifier-top)))) -(defpclass SubjectLocatorAssociationC(PointerAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "The actual topic which is associated - with the subject-locator.")) - (:documentation "A pointer that associates subject-locators, versions - and topics.")) - - +;;; SubjectLocatorAssociationC (defmethod delete-construct :before ((construct SubjectLocatorAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass PersistentIdAssociationC(PointerAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From PersistentIdAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "The actual topic which is associated - with the subject-identifier/psi.")) - (:documentation "A pointer that associates subject-identifiers, versions - and topics.")) - - +;;; PersistentIdAssociationC (defmethod delete-construct :before ((construct PersistentIdAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass TopicIdAssociationC(PointerAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From TopicIdAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "The actual topic which is associated - with the topic-identifier.")) - (:documentation "A pointer that associates topic-identifiers, versions - and topics.")) - - +;;; TopicIdAssociationC (defmethod delete-construct :before ((construct TopicIdAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass ItemIdAssociationC(PointerAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From ItemIDAssociationC(): parent-construct must be set") - :associate ReifiableConstructC - :documentation "The actual parent which is associated - with the item-identifier.")) - (:documentation "A pointer that associates item-identifiers, versions - and reifiable-constructs.")) - - +;;; ItemIdAssociationC (defmethod delete-construct :before ((construct ItemIdAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass PointerAssociationC (VersionedAssociationC) - ((identifier :initarg :identifier - :accessor identifier - :inherit t - :initform (error "From VersionedAssociationC(): identifier must be set") - :associate PointerC - :documentation "The actual data that is associated with - the pointer-association's parent.")) - (:documentation "An abstract base class for all versioned - pointer-associations.")) - - +;;; PointerAssociationC (defmethod delete-construct :before ((construct PointerAssociationC)) "Deletes the association-construct and the pointer if it is not used as an idengtiffier of any other object." @@ -1214,31 +1302,7 @@ (delete-construct id)))) -(defpclass VersionedAssociationC() - () - (:documentation "An abstract base class for all versioned associations.")) - - -;;; RoleC + AssociationC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass AssociationC(ReifiableConstructC ScopableC TypableC) - ((roles :associate (RoleAssociationC association) - :documentation "Contains all association-objects of all roles this - association contains.") - (in-topicmaps :associate (TopicMapC associations) - :many-to-many t - :documentation "List of all topic maps this association is - part of")) - (:index t) - (:documentation "Association in a Topic Map")) - - -(defpclass RoleC(ReifiableConstructC TypableC) - ((parent :associate (RoleAssociationC role) - :documentation "Associates this object with a role-association.") - (player :associate (PlayerAssociationC parent-construct) - :documentation "Associates this object with a player-association."))) - - +;;; AssociationC (defmethod delete-construct :before ((construct AssociationC)) "Removes all elephant-associations and deleted all roles that are not associated by another associations." @@ -1295,6 +1359,7 @@ (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) +;;; RoleC (defmethod delete-construct :before ((construct RoleC)) "Deletes all association-objects." (dolist (assoc (slot-p construct 'parent)) @@ -1341,7 +1406,7 @@ &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 (association parent-assoc) parent-construct) + when (eql (parent-construct parent-assoc) parent-construct) return parent-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -1399,18 +1464,7 @@ construct))) -;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass ReifiableConstructC(TopicMapConstructC) - ((item-identifiers :associate (ItemIdAssociationC identified-construct) - :inherit t - :documentation "A relation to all item-identifiers of - this construct.") - (reifier :associate (ReifierAssociationC reified-construct) - :inherit t - :documentation "A relation to a reifier-topic.")) - (:documentation "Reifiable constructs as per TMDM.")) - - +;;; ReifiableConstructC (defgeneric item-identifiers (construct &key revision) (:documentation "Returns the ItemIdentifierC-objects that correspond with the passed construct and the passed version.") @@ -1463,11 +1517,11 @@ :revision revision) construct)) (t - (make-construct 'ItemIdAssociationC - :start-revision revision - :parent-construct construct - :identifier item-identifier) - construct))))) + (make-instance 'ItemIdAssociationC + :start-revision revision + :parent-construct construct + :identifier item-identifier))) + construct))) (defgeneric delete-item-identifier (construct item-identifier &key revision) @@ -1509,10 +1563,10 @@ (all-constructs (merge-constructs (first all-constructs) construct)) (t - (make-construct 'ReifierAssociationC - :start-revision revision - :reifiable-construct construct - :reifier-topic merged-reifier-topic) + (make-instance 'ReifierAssociationC + :start-revision revision + :reifiable-construct construct + :reifier-topic merged-reifier-topic) construct)))))) @@ -1529,22 +1583,7 @@ construct))) -;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass TopicMapConstructC() - () - (:documentation "An abstract base class for all classes that describes - Topic Maps data.")) - - -;;; ScopableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass ScopableC() - ((themes :associate (ScopeAssociationC scopable-construct) - :inherit t - :documentation "Contains all association-objects that contain the - actual scope-topics.")) - (:documentation "An abstract base class for all constructs that are scoped.")) - - +;;; ScopableC (defmethod delete-construct :before ((construct ScopableC)) "Deletes all ScopeAssociationCs that are associated with the given object." (dolist (theme (slot-p construct 'themes)) @@ -1595,15 +1634,7 @@ construct))) -;;; TypableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass TypableC() - ((instance-of :associate (TypeAssociationC type-topic) - :inherit t - :documentation "Contains all association-objects that contain - the actual type-topic.")) - (:documentation "An abstract base class for all typed constructcs.")) - - +;;; TypableC (defmethod delete-construct :before ((construct TypableC)) "Deletes all TypeAssociationCs that are associated with this object." (dolist (type (slot-p construct 'instance-of)) @@ -1663,18 +1694,6 @@ construct))) -;;; DatatypableC -(defpclass DatatypableC() - ((datatype :accessor datatype - :initarg :datatype - :initform constants:*xml-string* - :documentation "The XML Schema datatype of the occurrencevalue - (optional, always IRI for resourceRef).")) - (:index t) - (:documentation "An abstract base class for characteristics that own - an xml-datatype.")) - - 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 Feb 20 09:49:30 2010 @@ -16,7 +16,8 @@ :unittests-constants) (:export :run-datamodel-tests :test-VersionInfoC - :test-VersionedConstructC)) + :test-VersionedConstructC + :test-ItemIdentifierC)) (declaim (optimize (debug 3))) @@ -91,11 +92,28 @@ (is (= (length (elephant:get-instances-by-class 'd::VersionInfoC)) 0)) (is (= (length (elephant:get-instances-by-class 'd::VersionedConstructC)) 0))))) - - +(test test-ItemIdentifierC () + "Tests various functions of the VersionedCoinstructC class." + (with-fixture with-empty-db (*db-dir*) + (setf d:*TM-REVISION* 100) + (let ((ii-1 (make-instance 'd:ItemIdentifierC + :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC + :uri "ii-2")) + (topic (make-instance 'd:TopicC))) + (is-false (d:identified-construct ii-1)) + (signals error (make-instance 'd:ItemIdentifierC)) + (is-false (item-identifiers topic)) + (d:add-item-identifier topic ii-1) + (format t ">>> ~a~%" (d::parent-construct ii-1)) + (is (= (length (d:item-identifiers topic)) 1)) + ))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) + (it.bese.fiveam:run! 'test-ItemIdentifierC) ) \ No newline at end of file

1 0

[isidorus-cvs] r197 - in branches/new-datamodel: docs src/model
by Lukas Giessmann 19 Feb '10

19 Feb '10

Author: lgiessmann Date: Fri Feb 19 13:34:28 2010 New Revision: 197 Log: new-datamodel: added the class DatatypableC as abstract base class for variants and occurrences; fixed some problems; updates the uml-schema Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Fri Feb 19 13:34:28 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Fri Feb 19 13:34:28 2010 @@ -26,11 +26,11 @@ ;;methods and functions :xtm-id :uri - :identifieid-construct + :identified-construct :item-identifiers - :reifier :add-item-identifier :delete-item-identifier + :reifier :add-reifier :delete-reifier :find-item-by-revision @@ -40,14 +40,12 @@ :instance-of :add-type :delete-type + :parent :add-parent :delete-parent :variants :add-variant :delete-variant - :association - :add-tm-association - :delete-tm-association :player :add-player :delete-player @@ -73,16 +71,23 @@ :delete-occurrence :player-in-roles :used-as-type - :ased-as-theme + :used-as-theme + :datatype :reified-construct :mark-as-deleted + :mark-as-deleted-p :in-topicmaps + :delete-construct ;;globals :*TM-REVISION*)) (in-package :datamodel) + +;;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 ;;TODO: use some exceptions --> more than one type, ;; identifier, not-mergable merges, ... ;;TODO: implement make-construct -> symbol @@ -423,12 +428,9 @@ (:documentation "Represents a TM topic.")) -(defpclass OccurrenceC(CharacteristicC) - ((datatype :accessor datatype - :initarg :datatype - :initform nil - :documentation "The XML Schema datatype of the occurrencevalue - (optional, always IRI for resourceRef)."))) +(defpclass OccurrenceC(CharacteristicC DatatypableC) + () + (:documentation "Represents a TM occurrence.")) (defpclass NameC(CharacteristicC) @@ -437,12 +439,9 @@ (:documentation "Scoped name of a topic.")) -(defpclass VariantC(CharacteristicC) - ((datatype :accessor datatype - :initarg :datatype - :initform nil - :documentation "The XML Schema datatype of the occurrencevalue - (optional, always IRI for resourceRef)."))) +(defpclass VariantC(CharacteristicC DatatypableC) + () + (:documentation "Represents a TM variant.")) (defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) @@ -1234,8 +1233,8 @@ (defpclass RoleC(ReifiableConstructC TypableC) - ((assocation :associate (RoleAssociationC role) - :documentation "Associates this object with a role-association.") + ((parent :associate (RoleAssociationC role) + :documentation "Associates this object with a role-association.") (player :associate (PlayerAssociationC parent-construct) :documentation "Associates this object with a player-association."))) @@ -1298,34 +1297,33 @@ (defmethod delete-construct :before ((construct RoleC)) "Deletes all association-objects." - (dolist (assoc (slot-p construct 'association)) + (dolist (assoc (slot-p construct 'parent)) (delete-construct assoc)) (dolist (assoc (slot-p construct 'player)) (delete-construct assoc))) -(defgeneric association (construct &key revision) - (:documentation "Returns the construct's parent corresponding to - the given revision.") - (:method ((construct RoleC) &key (revision *TM-REVISION*)) - (let ((valid-associations - (filter-slot-value-by-revision construct 'association - :start-revision revision))) - (when valid-associations - (parent-construct (first valid-associations)))))) - +(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 + :start-revision revision))) + (when valid-associations + (parent-construct (first valid-associations))))) + -(defmethod add-tm-association ((construct RoleC) (parent-construct AssociationC) +(defmethod add-parent ((construct RoleC) (parent-construct AssociationC) &key (revision *TM-REVISION*)) (let ((already-set-parent - (map 'list #'association - (filter-slot-value-by-revision construct 'association + (map 'list #'parent + (filter-slot-value-by-revision construct 'parent :start-revision revision)))) (cond ((and already-set-parent (eql (first already-set-parent) parent-construct)) (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'association) - when (eql parent-construct (association 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))) ((not already-set-parent) @@ -1339,10 +1337,10 @@ construct)) -(defmethod delete-tm-association ((construct RoleC) (parent-construct AssociationC) +(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) &key (revision (error "From delete-parent(): revision must be set"))) (let ((assoc-to-delete - (loop for parent-assoc in (slot-p construct 'assocaition) + (loop for parent-assoc in (slot-p construct 'parent) when (eql (association parent-assoc) parent-construct) return parent-assoc))) (when assoc-to-delete @@ -1665,7 +1663,16 @@ construct))) - +;;; DatatypableC +(defpclass DatatypableC() + ((datatype :accessor datatype + :initarg :datatype + :initform constants:*xml-string* + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef).")) + (:index t) + (:documentation "An abstract base class for characteristics that own + an xml-datatype."))

1 0

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

18 Feb '10

Author: lgiessmann Date: Thu Feb 18 15:36:34 2010 New Revision: 196 Log: new-datamodel: added some accessors and helpers to TopicC 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 Feb 18 15:36:34 2010 @@ -56,6 +56,25 @@ :delete-role :associations :topics + :psis + :add-psi + :delete-psi + :topic-identifiers + :add-topic-identifier + :delete-topic-identifier + :locators + :add-locator + :delete-locator + :names + :add-name + :delete-name + :occurrences + :add-occurrence + :delete-occurrence + :player-in-roles + :used-as-type + :ased-as-theme + :reified-construct :mark-as-deleted :in-topicmaps @@ -290,6 +309,81 @@ (:documentation "Represnets a topic map.")) +;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; SubjectLocatorC +;;; PersistentIdC +;;; ItemIdentifierC +;;; IdentifierC +;;; TopicIdentificationC +;;; PointerC +(defpclass SubjectLocatorC(IdentifierC) + () + (:index t) + (:documentation "A subject-locator that contains an uri-value and an + association to SubjectLocatorAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass PersistentIdC(IdentifierC) + () + (:index t) + (:documentation "A subject-identifier that contains an uri-value and an + association to PersistentIdAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass ItemIdentifierC(IdentifierC) + () + (:index t) + (:documentation "An item-identifier that contains an uri-value and an + association to ItemIdAssociationC's which are in turn + associated with RiefiableConstructC's.")) + + +(defpclass IdentifierC(PointerC) + () + (:documentation "An abstract base class for all TM-Identifiers.")) + + +(defpclass TopicIdentificationC(PointerC) + ((xtm-id :initarg :xtm-id + :accessor xtm-id + :type string + :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier") + :index t + :documentation "ID of the TM this identification came from.")) + (:index t) + (:documentation "Identify topic items through generalized topic-ids. + A topic may have many original topicids, the class + representing one of them.")) + + +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :inherit t + :type string + :initform (error "From PointerC(): uri must be set for a pointer") + :index t + :documentation "The actual value of a pointer, i.e. uri or ID.") + (identified-construct :initarg :identified-construct + :associate (PointerAssociationC identifier) + :inherit t)) + (:documentation "An abstract base class for all pointers.")) + + +(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 *TM-REVISION*)) + (let ((assocs + (map 'list #'parent-construct + (filter-slot-value-by-revision construct 'identified-construct + :start-revision revision)))) + (when assocs ;result must be nil or a list with one item + (first assocs))))) + + ;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpclass TopicC (ReifiableConstructC) ((topic-identifiers :associate (TopicIdAssociationC parent-construct) @@ -329,12 +423,6 @@ (:documentation "Represents a TM topic.")) -;;TODO: delete-construct, topic-identifiers, add-topic-identifier, -;; delete-topic-identifier, psis, add-psi, delete-psi, locators, -;; add-locator, delete-locator, names, add-name, delete-name, -;; occurrences, add-occurrence, delete-occurrence, player-in-roles -;; used-as-type, used-as-theme, reified-construct, in-topicmaps - (defpclass OccurrenceC(CharacteristicC) ((datatype :accessor datatype :initarg :datatype @@ -373,6 +461,319 @@ as an abstract class).")) +(defmethod delete-construct :before ((construct TopicC)) + "Deletes all association objects of the passed construct." + (dolist (assoc (append (slot-p construct 'topic-identifiers) + (slot-p construct 'psis) + (slot-p construct 'locators) + (slot-p construct 'names) + (slot-p construct 'occurrences) + (slot-p construct 'player-in-roles) + (slot-p construct 'used-as-type) + (slot-p construct 'used-as-theme) + (slot-p construct 'reified-construct))) + (delete-construct assoc)) + (dolist (assoc (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps assoc))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'topic-identifiers :start-revision revision))) + (map 'list #'identifier assocs)))) + + +(defgeneric add-topic-identifier (construct topic-identifier &key revision) + (:documentation "Adds the passed topic-identifier to the passed topic. + If the topic-identifier is already related with the passed + topic a new revision is added. + If the passed identifer already identifies another object + the identified-constructs are merged.") + (:method ((construct TopicC) (topic-identifier TopicIdentificationC) + &key (revision *TM-REVISION*)) + (let ((all-ids + (map 'list #'identifier + (remove-if #'marked-as-deleted-p + (slot-p construct 'topic-identifiers))))) + (cond ((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))) + (all-ids + (merge-constructs (identified-construct (first all-ids) + :revision revision) + construct)) + (t + (make-construct 'TopicIdAssociationC + :start-revision revision + :parent-construct construct + :identifier topic-identifier) + construct))))) + + +(defgeneric delete-topic-identifier (construct topic-identifier &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (topic-identifier TopicIdentificationC) + &key (revision (error "From delete-topic-identifier(): revision must be set"))) + (let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers) + when (eql (identifier ti-assoc) topic-identifier) + return ti-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'psis :start-revision revision))) + (map 'list #'identifier assocs)))) + + +(defgeneric add-psi (construct psi &key revision) + (:documentation "Adds the passed psi to the passed topic. + If the psi is already related with the passed + topic a new revision is added. + If the passed identifer already identifies another object + the identified-constructs are merged.") + (:method ((construct TopicC) (psi PersistentIdC) + &key (revision *TM-REVISION*)) + (let ((all-ids + (map 'list #'identifier + (remove-if #'marked-as-deleted-p + (slot-p construct 'psis))))) + (cond ((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))) + (all-ids + (merge-constructs (identified-construct (first all-ids) + :revision revision) + construct)) + (t + (make-construct 'PersistentIdAssociationC + :start-revision revision + :parent-construct construct + :identifier psi) + construct))))) + + +(defgeneric delete-psi (construct psi &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (psi PersistentIdC) + &key (revision (error "From delete-psi(): revision must be set"))) + (let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis) + when (eql (identifier psi-assoc) psi) + return psi-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'locators :start-revision revision))) + (map 'list #'identifier assocs)))) + + +(defgeneric add-locator (construct locator &key revision) + (:documentation "Adds the passed locator to the passed topic. + If the locator is already related with the passed + topic a new revision is added. + If the passed identifer already identifies another object + the identified-constructs are merged.") + (:method ((construct TopicC) (locator SubjectLocatorC) + &key (revision *TM-REVISION*)) + (let ((all-ids + (map 'list #'identifier + (remove-if #'marked-as-deleted-p + (slot-p construct 'locators))))) + (cond ((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))) + (all-ids + (merge-constructs (identified-construct (first all-ids) + :revision revision) + construct)) + (t + (make-construct 'SubjectLocatorAssociationC + :start-revision revision + :parent-construct construct + :identifier locator) + construct))))) + + +(defgeneric delete-locator (construct locator &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (locator SubjectLocatorC) + &key (revision (error "From delete-locator(): revision must be set"))) + (let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators) + when (eql (identifier loc-assoc) locator) + return loc-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'names :start-revision revision))) + (map 'list #'characteristic assocs)))) + + +(defgeneric add-name (construct name &key revision) + (:documentation "Adds the passed name to the passed topic. + If the name is already related with the passed + topic a new revision is added. + If the passed name already owns another object + an error is thrown.") + (:method ((construct TopicC) (name NameC) + &key (revision *TM-REVISION*)) + (when (not (eql (parent name) construct)) + (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" + name construct (parent name))) + (let ((all-names + (map 'list #'characteristic + (remove-if #'marked-as-deleted-p + (slot-p construct 'names))))) + (if (find name all-names) + (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) + when (eql (parent-construct name-assoc) name) + return name-assoc))) + (add-to-version-history name-assoc :start-revision revision)) + (make-construct 'NameAssociationC + :start-revision revision + :parent-construct construct + :characteristic name)) + construct))) + + +(defgeneric delete-name (construct name &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (name NameC) + &key (revision (error "From delete-name(): revision must be set"))) + (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) + when (eql (parent-construct name-assoc) name) + return name-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'occurences :start-revision revision))) + (map 'list #'characteristic assocs)))) + + +(defgeneric add-occurrence (construct occurrence &key revision) + (:documentation "Adds the passed occurrence to the passed topic. + If the occurrence is already related with the passed + topic a new revision is added. + If the passed occurrence already owns another object + an error is thrown.") + (:method ((construct TopicC) (occurrence OccurrenceC) + &key (revision *TM-REVISION*)) + (when (not (eql (parent occurrence) 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))) + (let ((all-occurrences + (map 'list #'characteristic + (remove-if #'marked-as-deleted-p + (slot-p construct 'occurrences))))) + (if (find occurrence all-occurrences) + (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) + when (eql (parent-construct occ-assoc) occurrence) + return occ-assoc))) + (add-to-version-history occ-assoc :start-revision revision)) + (make-construct 'OccurrenceAssociationC + :start-revision revision + :parent-construct construct + :characteristic occurrence)) + construct))) + + +(defgeneric delete-occurrence (construct occurrence &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (occurrence OccurrenceC) + &key (revision (error "From delete-occurrence(): revision must be set"))) + (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences) + when (eql (parent-construct occ-assoc) occurrence) + return occ-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'player-in-roles :start-revision revision))) + (map 'list #'parent-construct assocs)))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'used-as-type :start-revision revision))) + (map 'list #'typable-construct assocs)))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'used-as-theme :start-revision revision))) + (map 'list #'scopable-construct assocs)))) + + +(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 *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'reified-construct :start-revision revision))) + (map 'list #'reifiable-construct assocs)))) + + +(defgeneric in-topicmaps (construct &key revision) + (:documentation "Returns all TopicMapS-obejcts where the constrict is + contained in.")) + +(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*)) + (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) + + (defgeneric variants (construct &key revision) (:documentation "Returns all variants that correspond with the given revision and that are associated with the passed construct.") @@ -388,6 +789,9 @@ scopable-construct.") (:method ((construct ScopableC) (variant VariantC) &key (revision *TM-REVISION*)) + (when (not (eql (parent variant) 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))) (let ((all-variants (map 'list #'characteristic (remove-if #'marked-as-deleted-p @@ -425,6 +829,12 @@ (delete-construct parent-assoc))) +(defmethod delete-construct :before ((construct NameC)) + "Deletes all association-obejcts." + (dolist (variant-assoc (slot-p construct 'variants)) + (delete-construct variant-assoc))) + + (defgeneric parent (construct &key revision) (:documentation "Returns the parent construct of the passed object that corresponds with the given revision. The returned construct @@ -434,10 +844,7 @@ (filter-slot-value-by-revision construct 'parent :start-revision revision))) (when valid-associations - (let ((valid-assoc (first valid-associations))) - (if (typep valid-assoc 'VariantAssociationC) - (name valid-assoc) - (topic valid-assoc))))))) + (parent-construct (first valid-associations)))))) (defgeneric add-parent (construct parent-construct &key revision) @@ -448,14 +855,15 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC) &key (revision *TM-REVISION*)) (let ((already-set-topic - (map 'list #'topic + (map 'list #'parent-construct (filter-slot-value-by-revision construct 'parent :start-revision revision)))) (cond ((and already-set-topic (eql (first already-set-topic) parent-construct)) (let ((parent-assoc (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct (topic parent-assoc)) + when (eql parent-construct (parent-construct + parent-assoc)) return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) ((not already-set-topic) @@ -474,14 +882,14 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct NameC) &key (revision *TM-REVISION*)) (let ((already-set-name - (map 'list #'name + (map 'list #'characteristic (filter-slot-value-by-revision construct 'parent :start-revision revision)))) (cond ((and already-set-name (eql (first already-set-name) parent-construct)) (let ((parent-assoc (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct (name parent-assoc)) + when (eql parent-construct (characteristic parent-assoc)) return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) ((not already-set-name) @@ -504,7 +912,7 @@ &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 (topic parent-assoc) parent-construct) + when (eql (parent-construct parent-assoc) parent-construct) return parent-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -515,7 +923,7 @@ &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 (name parent-assoc) parent-construct) + when (eql (characteristic parent-assoc) parent-construct) return parent-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -993,81 +1401,6 @@ construct))) -;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; SubjectLocatorC -;;; PersistentIdC -;;; ItemIdentifierC -;;; IdentifierC -;;; TopicIdentificationC -;;; PointerC -(defpclass SubjectLocatorC(IdentifierC) - () - (:index t) - (:documentation "A subject-locator that contains an uri-value and an - association to SubjectLocatorAssociationC's which are in - turn associated with TopicC's.")) - - -(defpclass PersistentIdC(IdentifierC) - () - (:index t) - (:documentation "A subject-identifier that contains an uri-value and an - association to PersistentIdAssociationC's which are in - turn associated with TopicC's.")) - - -(defpclass ItemIdentifierC(IdentifierC) - () - (:index t) - (:documentation "An item-identifier that contains an uri-value and an - association to ItemIdAssociationC's which are in turn - associated with RiefiableConstructC's.")) - - -(defpclass IdentifierC(PointerC) - () - (:documentation "An abstract base class for all TM-Identifiers.")) - - -(defpclass TopicIdentificationC(PointerC) - ((xtm-id :initarg :xtm-id - :accessor xtm-id - :type string - :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier") - :index t - :documentation "ID of the TM this identification came from.")) - (:index t) - (:documentation "Identify topic items through generalized topic-ids. - A topic may have many original topicids, the class - representing one of them.")) - - -(defpclass PointerC(TopicMapConstructC) - ((uri :initarg :uri - :accessor uri - :inherit t - :type string - :initform (error "From PointerC(): uri must be set for a pointer") - :index t - :documentation "The actual value of a pointer, i.e. uri or ID.") - (identified-construct :initarg :identified-construct - :associate (PointerAssociationC identifier) - :inherit t)) - (:documentation "An abstract base class for all pointers.")) - - -(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 *TM-REVISION*)) - (let ((assocs - (map 'list #'parent-construct - (filter-slot-value-by-revision construct 'identified-construct - :start-revision revision)))) - (when assocs ;result must be nil or a list with one item - (first assocs))))) - - ;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpclass ReifiableConstructC(TopicMapConstructC) ((item-identifiers :associate (ItemIdAssociationC identified-construct)

1 0

[isidorus-cvs] r195 - in branches/new-datamodel: docs src/model
by Lukas Giessmann 17 Feb '10

17 Feb '10

Author: lgiessmann Date: Wed Feb 17 16:39:10 2010 New Revision: 195 Log: new-datamodel: updated the uml-schema; started to implement TopiC; implemented TopicMapC Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Wed Feb 17 16:39:10 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Wed Feb 17 16:39:10 2010 @@ -11,6 +11,7 @@ (:use :cl :elephant :constants) (:nicknames :d) (:export ;;classes + :TopicMapC :AssociationC :RoleC :OccurrenceC @@ -53,6 +54,8 @@ :roles :add-role :delete-role + :associations + :topics :mark-as-deleted :in-topicmaps @@ -72,31 +75,6 @@ ;; one revision-infos - -;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;; -(defpclass TopicC (TopicMapConstructC) - () - (:documentation "A temporary emtpy class to avoid compiler-errors.")) - - -(defgeneric merge-constructs(construc-1 construct-2 &key revision) - (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) - &key (revision *TM-REVISION*)) - (or construct-1 construct-2 revision))) - - -(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys) - (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*)) - (or class-symbol start-revision))) -;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - - - - - - ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *TM-REVISION* 0) @@ -301,7 +279,62 @@ (setf (end-revision last-version) revision)))) -;;; Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; TopicMapC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(elephant:defpclass TopicMapC (ReifiableConstructC) + ((topics :accessor topics + :associate (TopicC in-topicmaps) + :documentation "List of topics that explicitly belong to this TM.") + (associations :accessor associations + :associate (AssociationC in-topicmaps) + :documentation "List of associations that belong to this TM.")) + (:documentation "Represnets a topic map.")) + + +;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defpclass TopicC (ReifiableConstructC) + ((topic-identifiers :associate (TopicIdAssociationC parent-construct) + :documentation "Contains all association objects that + relate a topic with its actual + topic-identifiers.") + (psis :associate (PersistentIdAssociationC parent-construct) + :documentation "Contains all association objects that relate a topic + with its actual psis.") + (locators :associate (PersistentIdAssociationC parent-construct) + :documentation "Contains all association objects that relate a + topic with its actual subject-lcoators.") + (names :associate (NameAssociationC parent-construct) + :documentation "Contains all association objects that relate a topic + with its actual names.") + (occurrences :associate (OccurrenceAssociationC parent-construct) + :documentation "Contains all association objects that relate a + topic with its actual occurrences.") + (player-in-roles :associate (PlayerAssociationC player-topic) + :documentation "Contains all association objects that relate + a topic that is a player with its role.") + (used-as-type :associate (TypeAssociationC type-topic) + :documentation "Contains all association objects that relate a + topic that is a type with its typable obejct.") + (used-as-theme :associate (ScopeAssociationC theme-topic) + :documentation "Contains all association objects that relate a + topic that is a theme with its scoppable + object.") + (reified-construct :associate (ReifiedAssociationC reifier-topic) + :documentation "Contains all association objects that + relate a topic that is a reifier with + its reified object.") + (in-topicmaps :associate (TopicMapC topics) + :many-to-many t + :documentation "List of all topic maps this topic is part of.")) + (:index t) + (:documentation "Represents a TM topic.")) + + +;;TODO: delete-construct, topic-identifiers, add-topic-identifier, +;; delete-topic-identifier, psis, add-psi, delete-psi, locators, +;; add-locator, delete-locator, names, add-name, delete-name, +;; occurrences, add-occurrence, delete-occurrence, player-in-roles +;; used-as-type, used-as-theme, reified-construct, in-topicmaps + (defpclass OccurrenceC(CharacteristicC) ((datatype :accessor datatype :initarg :datatype @@ -311,7 +344,7 @@ (defpclass NameC(CharacteristicC) - ((variants :associate (VariantAssociationC name) + ((variants :associate (VariantAssociationC parent-construct) :documentation "Associates this obejct with varian-associations.")) (:documentation "Scoped name of a topic.")) @@ -329,13 +362,13 @@ :inherit t :documentation "Assocates the characterist obejct with the parent-association.") - (charavalue :initarg :charvalue - :accessor charvalue - :type string - :inherit t - :initform "" - :index t - :documentation "Contains the actual data of this object.")) + (charvalue :initarg :charvalue + :accessor charvalue + :type string + :inherit t + :initform "" + :index t + :documentation "Contains the actual data of this object.")) (:documentation "Scoped characteristic of a topic (meant to be used as an abstract class).")) @@ -368,7 +401,7 @@ (make-instance 'VariantAssociationC :start-revision revision :characteristic variant - :name construct))) + :parent-construct construct))) construct)) @@ -430,7 +463,7 @@ 'OccurrenceAssociationC 'NameAssociationC) :start-revision revision - :topic parent-construct + :parent-construct parent-construct :characteristic construct)) (t (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" @@ -454,7 +487,7 @@ ((not already-set-name) (make-instance 'VariantAssociationC :start-revision revision - :name parent-construct + :parent-construct parent-construct :characteristic construct)) (t (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" @@ -512,11 +545,11 @@ :initform (error "From PlayerAssociationC(): player-topic must be set") :documentation "Associates this object with a topic that is a player.") - (role :initarg :role - :accessor role - :associate RoleC - :initform (error "From PlayerAssociationC(): role must be set") - :documentation "Associates this object with the parent-association.")) + (parent-construct :initarg :parent-construct + :accessor parent-construct + :associate RoleC + :initform (error "From PlayerAssociationC(): parent-construct must be set") + :documentation "Associates this object with the parent-association.")) (:documentation "This class associates roles and their player in given revisions.")) @@ -524,7 +557,7 @@ (defmethod delete-construct :before ((construct PlayerAssociationC)) "Deletes all elephant-associations." (delete-1-n-association construct 'player-topic) - (delete-1-n-association construct 'role)) + (delete-1-n-association construct 'parent-construct)) (defpclass RoleAssociationC(VersionedAssociationC) @@ -536,7 +569,7 @@ (parent-construct :initarg :parent-construct :accessor parent-construct :associate AssociationC - :initform (error "From RoleAssociationC(): association must be set") + :initform (error "From RoleAssociationC(): parent-construct must be set") :documentation "Assocates thius object with an association-object.")) (:documentation "Associates roles with assoications and adds some @@ -554,45 +587,45 @@ (defpclass VariantAssociationC(CharateristicAssociationC) - ((name :initarg :name - :accessor name - :initform (error "From VariantAssociationC(): name must be set") - :associate NameC - :documentation "Associates this object with a name.")) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From VariantAssociationC(): parent-construct must be set") + :associate NameC + :documentation "Associates this object with a name.")) (:documentation "Associates variant objects with name obejcts. Additionally version-infos are stored.")) (defmethod delete-construct :before ((construct VariantAssociationC)) - (delete-1-n-association construct 'name)) + (delete-1-n-association construct 'parent-construct)) (defpclass NameAssociationC(CharacteristicAssociationC) - ((topic :initarg :topic - :accessor topic - :initform (error "From NameAssociationC(): topic must be set") - :associate TopicC - :documentation "Associates this object with a topic.")) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From NameAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "Associates this object with a topic.")) (:documentation "Associates name objects with their parent topics. Additionally version-infos are stored.")) (defmethod delete-construct :before ((construct NameAssociationC)) - (delete-1-n-association construct 'topic)) + (delete-1-n-association construct 'parent-construct)) (defpclass OccurrenceAssociationC(CharacteristicAssociationC) - ((topic :initarg :topic - :accessor topic - :initform (error "From OccurrenceAssociationC(): topic must be set") - :associate TopicC - :documentation "Associates this object with a topic.")) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From OccurrenceAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "Associates this object with a topic.")) (:documentation "Associates occurrence objects with their parent topics. Additionally version-infos are stored.")) (defmethod delete-construct :before ((construct OccurrenceAssociationC)) - (delete-1-n-association construct 'topic)) + (delete-1-n-association construct 'parent-construct)) (defpclass CharacteristicAssociationC(VersionedAssociationC) @@ -795,7 +828,7 @@ (defpclass RoleC(ReifiableConstructC TypableC) ((assocation :associate (RoleAssociationC role) :documentation "Associates this object with a role-association.") - (player :associate (PlayerAssociationC parent-role) + (player :associate (PlayerAssociationC parent-construct) :documentation "Associates this object with a player-association."))) @@ -938,7 +971,7 @@ ((not already-set-player) (make-instance 'PlayerAssociationC :start-revision revision - :role construct + :parent-construct construct :player-topic player-topic)) (t (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a" @@ -1037,13 +1070,11 @@ ;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpclass ReifiableConstructC(TopicMapConstructC) - ((item-identifiers :initarg :item-identifiers - :associate (ItemIdAssociationC identified-construct) + ((item-identifiers :associate (ItemIdAssociationC identified-construct) :inherit t :documentation "A relation to all item-identifiers of this construct.") - (reifier :initarg :reifier - :associate (ReifierAssociationC reified-construct) + (reifier :associate (ReifierAssociationC reified-construct) :inherit t :documentation "A relation to a reifier-topic.")) (:documentation "Reifiable constructs as per TMDM.")) @@ -1298,4 +1329,31 @@ return type-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) - construct))) \ No newline at end of file + construct))) + + + + + + + + + + + + + + + + +;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric merge-constructs(construc-1 construct-2 &key revision) + (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) + &key (revision *TM-REVISION*)) + (or construct-1 construct-2 revision))) + + +(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys) + (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*)) + (or class-symbol start-revision))) +;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file

1 0

[isidorus-cvs] r194 - in branches/new-datamodel: docs src/model
by Lukas Giessmann 17 Feb '10

17 Feb '10

Author: lgiessmann Date: Wed Feb 17 14:55:29 2010 New Revision: 194 Log: new-datamodel: updated the uml-schema; implemented AssociationC Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Wed Feb 17 14:55:29 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Wed Feb 17 14:55:29 2010 @@ -11,6 +11,7 @@ (:use :cl :elephant :constants) (:nicknames :d) (:export ;;classes + :AssociationC :RoleC :OccurrenceC :NameC @@ -43,13 +44,17 @@ :variants :add-variant :delete-variant - :parent - :add-parent - :delete-parent + :association + :add-tm-association + :delete-tm-association :player :add-player :delete-player + :roles + :add-role + :delete-role :mark-as-deleted + :in-topicmaps ;;globals :*TM-REVISION*)) @@ -57,7 +62,7 @@ (in-package :datamodel) ;;TODO: use some exceptions --> more than one type, -;; identifier, not-mergeable merges, ... +;; identifier, not-mergable merges, ... ;;TODO: implement make-construct -> symbol ;; replace the latest make-construct-method ;;TODO: implement merge-construct -> ReifiableConstructC -> ... @@ -73,10 +78,6 @@ () (:documentation "A temporary emtpy class to avoid compiler-errors.")) -(defpclass AssociationC (TopicMapConstructC) - () - (:documentation "A temporary emtpy class to avoid compiler-errors.")) - (defgeneric merge-constructs(construc-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) @@ -310,11 +311,35 @@ (defpclass NameC(CharacteristicC) - ((variants :associate (VaraitnAssociationC name) + ((variants :associate (VariantAssociationC name) :documentation "Associates this obejct with varian-associations.")) (:documentation "Scoped name of a topic.")) +(defpclass VariantC(CharacteristicC) + ((datatype :accessor datatype + :initarg :datatype + :initform nil + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef)."))) + + +(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) + ((parent :associate (CharacteriticAssociationC characteristic) + :inherit t + :documentation "Assocates the characterist obejct with the + parent-association.") + (charavalue :initarg :charvalue + :accessor charvalue + :type string + :inherit t + :initform "" + :index t + :documentation "Contains the actual data of this object.")) + (:documentation "Scoped characteristic of a topic (meant to be used + as an abstract class).")) + + (defgeneric variants (construct &key revision) (:documentation "Returns all variants that correspond with the given revision and that are associated with the passed construct.") @@ -351,7 +376,7 @@ (:documentation "Deletes the passed variant by marking it's association as deleted in the passed revision.") (:method ((construct NameC) (variant VariantC) - &key (revision (error "From delete-theme(): revision must be set"))) + &key (revision (error "From delete-variant(): revision must be set"))) (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct 'variants) when (eql (characteristic variant-assoc) variant) @@ -361,30 +386,6 @@ construct))) -(defpclass VariantC(CharacteristicC) - ((datatype :accessor datatype - :initarg :datatype - :initform nil - :documentation "The XML Schema datatype of the occurrencevalue - (optional, always IRI for resourceRef)."))) - - -(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) - ((parent :associate (CharacteriticAssociationC characteristic) - :inherit t - :documentation "Assocates the characterist obejct with the - parent-association.") - (charavalue :initarg :charvalue - :accessor charvalue - :type string - :inherit t - :initform "" - :index t - :documentation "Contains the actual data of this object.")) - (:documentation "Scoped characteristic of a topic (meant to be used - as an abstract class).")) - - (defmethod delete-construct :before ((construct CharacteristicC)) "Deletes all association-obejcts." (dolist (parent-assoc (slot-p construct 'parent)) @@ -532,11 +533,12 @@ :associate RoleC :initform (error "From RoleAssociationC(): role must be set") :documentation "Associates this objetc with a role-object.") - (association :initarg :association - :accessor association - :associate AssociationC - :initform (error "From RoleAssociationC(): association must be set") - :documentation "Assocates thius object with an association-object.")) + (parent-construct :initarg :parent-construct + :accessor parent-construct + :associate AssociationC + :initform (error "From RoleAssociationC(): association must be set") + :documentation "Assocates thius object with an + association-object.")) (:documentation "Associates roles with assoications and adds some version-infos between these realtions.")) @@ -548,7 +550,7 @@ (delete-1-n-association construct 'role) (when (not (slot-p role 'parent)) (delete-construct role)) - (delete-1-n-association construct 'association))) + (delete-1-n-association construct 'parent-construct))) (defpclass VariantAssociationC(CharateristicAssociationC) @@ -687,7 +689,7 @@ (delete-1-n-association construct 'reifiable-construct) (let ((reifier-top (slot-p construct 'reifier-topic))) (delete-1-n-association construct 'reifier-topic) - (when (= (length (all-reified-constructs reifier-top)) 0) + (when (= (length (slot-p reifier-top 'reified-construct)) 0) (delete-construct reifier-top)))) @@ -777,43 +779,111 @@ (:documentation "An abstract base class for all versioned associations.")) -;;; RoleC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; RoleC + AssociationC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defpclass AssociationC(ReifiableConstructC ScopableC TypableC) + ((roles :associate (RoleAssociationC association) + :documentation "Contains all association-objects of all roles this + association contains.") + (in-topicmaps :associate (TopicMapC associations) + :many-to-many t + :documentation "List of all topic maps this association is + part of")) + (:index t) + (:documentation "Association in a Topic Map")) + + (defpclass RoleC(ReifiableConstructC TypableC) - ((parent :associate (RoleAssociationC role) - :documentation "Associates this object with a role-association.") + ((assocation :associate (RoleAssociationC role) + :documentation "Associates this object with a role-association.") (player :associate (PlayerAssociationC parent-role) :documentation "Associates this object with a player-association."))) +(defmethod delete-construct :before ((construct AssociationC)) + "Removes all elephant-associations and deleted all roles that are not + associated by another associations." + (dolist (assoc (slot-p construct 'roles)) + (delete-construct assoc)) + (dolist (tm (in-topicmaps construct)) + (remove-association construct 'in-topicmaps tm))) + + +(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 *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'roles + :start-revision revision))) + (map 'list #'role valid-associations)))) + + +(defgeneric add-role (construct role &key revision) + (:documentation "Adds the given role to the passed association-construct.") + (:method ((construct AssociationC) (role RoleC) + &key (revision *TM-REVISION*)) + (let ((all-roles + (map 'list #'role + (remove-if #'marked-as-deleted-p (slot-p construct 'roles))))) + (if (find role all-roles) + (let ((role-assoc + (loop for role-assoc in (slot-p construct 'roles) + when (eql (role role-assoc) role) + return role-assoc))) + (add-to-version-history role-assoc :start-revision revision)) + (make-instance 'RoleAssociationC + :start-revision revision + :role role + :association construct))) + construct)) + + +(defgeneric delete-role (construct role &key revision) + (:documentation "Deletes the passed role by marking it's association as + deleted in the passed revision.") + (:method ((construct AssociationC) (role RoleC) + &key (revision (error "From delete-role(): revision must be set"))) + (let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles) + when (eql (role role-assoc) role) + return role-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + +(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*)) + (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) + + (defmethod delete-construct :before ((construct RoleC)) "Deletes all association-objects." - (dolist (assoc (slot-p construct 'parent)) + (dolist (assoc (slot-p construct 'association)) (delete-construct assoc)) (dolist (assoc (slot-p construct 'player)) (delete-construct assoc))) -(defgeneric parent (construct &key revision) +(defgeneric association (construct &key revision) (:documentation "Returns the construct's parent corresponding to the given revision.") (:method ((construct RoleC) &key (revision *TM-REVISION*)) (let ((valid-associations - (filter-slot-value-by-revision construct 'parent + (filter-slot-value-by-revision construct 'association :start-revision revision))) (when valid-associations - (association (first valid-associations)))))) + (parent-construct (first valid-associations)))))) -(defmethod add-parent ((construct RoleC) (parent-construct AssociationC) - &key (revision *TM-REVISION*)) +(defmethod add-tm-association ((construct RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) (let ((already-set-parent (map 'list #'association - (filter-slot-value-by-revision construct 'parent + (filter-slot-value-by-revision construct 'association :start-revision revision)))) (cond ((and already-set-parent (eql (first already-set-parent) parent-construct)) (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'parent) + (loop for parent-assoc in (slot-p construct 'association) when (eql parent-construct (association parent-assoc)) return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) @@ -821,17 +891,17 @@ (make-instance 'RoleAssociationC :start-revision revision :role construct - :association parent-construct)) + :parent-construct parent-construct)) (t (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a" parent-construct construct already-set-parent))) construct)) -(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) +(defmethod delete-tm-association ((construct RoleC) (parent-construct AssociationC) &key (revision (error "From delete-parent(): revision must be set"))) (let ((assoc-to-delete - (loop for parent-assoc in (slot-p construct 'parent) + (loop for parent-assoc in (slot-p construct 'assocaition) when (eql (association parent-assoc) parent-construct) return parent-assoc))) (when assoc-to-delete @@ -1063,7 +1133,8 @@ (when (reifier construct) (merge-constructs (reifier construct) reifier-topic)))) (let ((all-constructs - (all-reified-constructs merged-reifier-topic :with-deleted nil))) + (remove-if #'marked-as-deleted-p + (slot-p reifier-topic 'reified-construct)))) (cond ((find construct all-constructs) (let ((reifier-assoc (loop for reifier-assoc in

1 0

[isidorus-cvs] r193 - in branches/new-datamodel: docs src/model
by Lukas Giessmann 17 Feb '10

17 Feb '10

Author: lgiessmann Date: Wed Feb 17 13:59:30 2010 New Revision: 193 Log: new-datamodel: fixed some problems; removed some unnecessary functions; implemented RoleC, PlayerAssociationC, RoleAssociationC; updated the UML-schema Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Wed Feb 17 13:59:30 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Wed Feb 17 13:59:30 2010 @@ -11,6 +11,10 @@ (:use :cl :elephant :constants) (:nicknames :d) (:export ;;classes + :RoleC + :OccurrenceC + :NameC + :VariantC :PersistentIdC :ItemIdentifierC :SubjectLocatorC @@ -21,7 +25,6 @@ :xtm-id :uri :identifieid-construct - :all-identified-constructs :item-identifiers :reifier :add-item-identifier @@ -37,6 +40,15 @@ :delete-type :add-parent :delete-parent + :variants + :add-variant + :delete-variant + :parent + :add-parent + :delete-parent + :player + :add-player + :delete-player :mark-as-deleted ;;globals @@ -44,11 +56,8 @@ (in-package :datamodel) - -;;TODO: implement delete-item-identifier -;;TODO: implement delete-reifier -;;TODO: implement all-reified-constructs (:with-deleted t) -> TopicC -;; the method should return all reifed-constructs of the given topic +;;TODO: use some exceptions --> more than one type, +;; identifier, not-mergeable merges, ... ;;TODO: implement make-construct -> symbol ;; replace the latest make-construct-method ;;TODO: implement merge-construct -> ReifiableConstructC -> ... @@ -60,30 +69,21 @@ ;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;; -(defpclass NameC (TopicMapConstructC) +(defpclass TopicC (TopicMapConstructC) () (:documentation "A temporary emtpy class to avoid compiler-errors.")) -(defpclass OccurrenceC (TopicMapConstructC) +(defpclass AssociationC (TopicMapConstructC) () (:documentation "A temporary emtpy class to avoid compiler-errors.")) -(defpclass TopicC (TopicMapConstructC) - () - (:documentation "A temporary emtpy class to avoid compiler-errors.")) - (defgeneric merge-constructs(construc-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) &key (revision *TM-REVISION*)) (or construct-1 construct-2 revision))) -(defgeneric all-reified-constructs(topic &key with-deleted) - (:method ((topic TopicC) &key (with-deleted t)) - (or topic with-deleted))) - - (defgeneric make-construct (class-symbol &key start-revision &allow-other-keys) (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*)) (or class-symbol start-revision))) @@ -301,6 +301,74 @@ ;;; Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defpclass OccurrenceC(CharacteristicC) + ((datatype :accessor datatype + :initarg :datatype + :initform nil + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef)."))) + + +(defpclass NameC(CharacteristicC) + ((variants :associate (VaraitnAssociationC name) + :documentation "Associates this obejct with varian-associations.")) + (:documentation "Scoped name of a topic.")) + + +(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 *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'variants + :start-revision revision))) + (map 'list #'characteristic valid-associations)))) + + +(defgeneric add-variant (construct variant &key revision) + (:documentation "Adds the given theme-topic to the passed + scopable-construct.") + (:method ((construct ScopableC) (variant VariantC) + &key (revision *TM-REVISION*)) + (let ((all-variants + (map 'list #'characteristic + (remove-if #'marked-as-deleted-p + (slot-p construct 'variants))))) + (if (find variant all-variants) + (let ((variant-assoc + (loop for variant-assoc in (slot-p construct 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (add-to-version-history variant-assoc :start-revision revision)) + (make-instance 'VariantAssociationC + :start-revision revision + :characteristic variant + :name construct))) + construct)) + + +(defgeneric delete-variant (construct variant &key revision) + (:documentation "Deletes the passed variant by marking it's association as + deleted in the passed revision.") + (:method ((construct NameC) (variant VariantC) + &key (revision (error "From delete-theme(): revision must be set"))) + (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct + 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + +(defpclass VariantC(CharacteristicC) + ((datatype :accessor datatype + :initarg :datatype + :initform nil + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef)."))) + + (defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) ((parent :associate (CharacteriticAssociationC characteristic) :inherit t @@ -421,6 +489,8 @@ ;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; PlayerAssociationC +;;; RoleAssociationC ;;; VariantAssociationC ;;; NameAssociationC ;;; OccurrenceAssociationC @@ -434,13 +504,59 @@ ;;; ItemIdAssociationC ;;; PointerAssociationC ;;; VersionedAssociationC +(defpclass PlayerAssociationC(VersionedAssociationC) + ((player-topic :initarg :player-topic + :accessor player-topic + :associate TopicC + :initform (error "From PlayerAssociationC(): player-topic must be set") + :documentation "Associates this object with a topic that is + a player.") + (role :initarg :role + :accessor role + :associate RoleC + :initform (error "From PlayerAssociationC(): role must be set") + :documentation "Associates this object with the parent-association.")) + (:documentation "This class associates roles and their player in given + revisions.")) + + +(defmethod delete-construct :before ((construct PlayerAssociationC)) + "Deletes all elephant-associations." + (delete-1-n-association construct 'player-topic) + (delete-1-n-association construct 'role)) + + +(defpclass RoleAssociationC(VersionedAssociationC) + ((role :initarg :role + :accessor role + :associate RoleC + :initform (error "From RoleAssociationC(): role must be set") + :documentation "Associates this objetc with a role-object.") + (association :initarg :association + :accessor association + :associate AssociationC + :initform (error "From RoleAssociationC(): association must be set") + :documentation "Assocates thius object with an association-object.")) + (:documentation "Associates roles with assoications and adds some + version-infos between these realtions.")) + + +(defmethod delete-construct :before ((construct RoleAssociationC)) + "Deletes all elephant-associations and the entire role if it is not + associated with another AssociationC object." + (let ((role (role construct))) + (delete-1-n-association construct 'role) + (when (not (slot-p role 'parent)) + (delete-construct role)) + (delete-1-n-association construct 'association))) + + (defpclass VariantAssociationC(CharateristicAssociationC) ((name :initarg :name :accessor name :initform (error "From VariantAssociationC(): name must be set") :associate NameC :documentation "Associates this object with a name.")) - (:index t) (:documentation "Associates variant objects with name obejcts. Additionally version-infos are stored.")) @@ -455,7 +571,6 @@ :initform (error "From NameAssociationC(): topic must be set") :associate TopicC :documentation "Associates this object with a topic.")) - (:index t) (:documentation "Associates name objects with their parent topics. Additionally version-infos are stored.")) @@ -470,7 +585,6 @@ :initform (error "From OccurrenceAssociationC(): topic must be set") :associate TopicC :documentation "Associates this object with a topic.")) - (:index t) (:documentation "Associates occurrence objects with their parent topics. Additionally version-infos are stored.")) @@ -514,7 +628,6 @@ :documentation "Associates this object with the typable construct that is typed by the type-topic.")) - (:index t) (:documentation "This class associates topics that are used as type for typable constructcs. Additionally there are stored some version-infos.")) @@ -540,7 +653,6 @@ :documentation "Associates this object with the socpable construct that is scoped by the scope-topic.")) - (:index t) (:documentation "This class associates topics that are used as scope with scopable construtcs. Additionally there are stored some version-infos")) @@ -565,7 +677,6 @@ :associate TopicC :documentation "The reifier-topic that reifies the reifiable-construct.")) - (:index t) (:documentation "A versioned-association that relates a reifiable-construct with a topic.")) @@ -587,7 +698,6 @@ :associate TopicC :documentation "The actual topic which is associated with the subject-locator.")) - (:index t) (:documentation "A pointer that associates subject-locators, versions and topics.")) @@ -603,7 +713,6 @@ :associate TopicC :documentation "The actual topic which is associated with the subject-identifier/psi.")) - (:index t) (:documentation "A pointer that associates subject-identifiers, versions and topics.")) @@ -619,7 +728,6 @@ :associate TopicC :documentation "The actual topic which is associated with the topic-identifier.")) - (:index t) (:documentation "A pointer that associates topic-identifiers, versions and topics.")) @@ -635,7 +743,6 @@ :associate ReifiableConstructC :documentation "The actual parent which is associated with the item-identifier.")) - (:index t) (:documentation "A pointer that associates item-identifiers, versions and reifiable-constructs.")) @@ -661,7 +768,7 @@ as an idengtiffier of any other object." (let ((id (slot-p construct 'identifier))) (delete-1-n-association construct 'identifier) - (when (= (length (all-identified-constructs id)) 0) + (when (= (length (slot-p id 'identified-construct)) 0) (delete-construct id)))) @@ -670,6 +777,119 @@ (:documentation "An abstract base class for all versioned associations.")) +;;; RoleC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defpclass RoleC(ReifiableConstructC TypableC) + ((parent :associate (RoleAssociationC role) + :documentation "Associates this object with a role-association.") + (player :associate (PlayerAssociationC parent-role) + :documentation "Associates this object with a player-association."))) + + +(defmethod delete-construct :before ((construct RoleC)) + "Deletes all association-objects." + (dolist (assoc (slot-p construct 'parent)) + (delete-construct assoc)) + (dolist (assoc (slot-p construct 'player)) + (delete-construct assoc))) + + +(defgeneric parent (construct &key revision) + (:documentation "Returns the construct's parent corresponding to + the given revision.") + (:method ((construct RoleC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'parent + :start-revision revision))) + (when valid-associations + (association (first valid-associations)))))) + + +(defmethod add-parent ((construct RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) + (let ((already-set-parent + (map 'list #'association + (filter-slot-value-by-revision construct 'parent + :start-revision revision)))) + (cond ((and already-set-parent + (eql (first already-set-parent) parent-construct)) + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct (association parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc :start-revision revision))) + ((not already-set-parent) + (make-instance 'RoleAssociationC + :start-revision revision + :role construct + :association parent-construct)) + (t + (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a" + parent-construct construct already-set-parent))) + construct)) + + +(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) + &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 (association parent-assoc) parent-construct) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct)) + + +(defgeneric player (construct &key revision) + (:documentation "Returns the construct's player corresponding to + the given revision.") + (:method ((construct RoleC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'player + :start-revision revision))) + (when valid-associations + (player-topic (first valid-associations)))))) + + +(defgeneric add-player (construct player-topic &key revision) + (:documentation "Adds a topic as a player to a role in the given revision.") + (:method ((construct RoleC) (player-topic TopicC) + &key (revision *TM-REVISION*)) + (let ((already-set-player + (map 'list #'player-topic + (filter-slot-value-by-revision construct 'player + :start-revision revision)))) + (cond ((and already-set-player + (eql (first already-set-player) player-topic)) + (let ((player-assoc + (loop for player-assoc in (slot-p construct 'player) + when (eql player-topic (player-topic player-assoc)) + return player-assoc))) + (add-to-version-history player-assoc :start-revision revision))) + ((not already-set-player) + (make-instance 'PlayerAssociationC + :start-revision revision + :role construct + :player-topic player-topic)) + (t + (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a" + player-topic construct already-set-player))) + construct))) + + +(defgeneric delete-player (construct player-topic &key revision) + (:documentation "Deletes the passed topic as a player of the passed role + object by marking its association-object as deleted.") + (:method ((construct RoleC) (player-topic TopicC) + &key (revision (error "From delete-parent(): revision must be set"))) + (let ((assoc-to-delete + (loop for player-assoc in (slot-p construct 'player) + when (eql (player-topic player-assoc) player-topic) + return player-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + ;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; SubjectLocatorC ;;; PersistentIdC @@ -745,18 +965,6 @@ (first assocs))))) -(defgeneric all-identified-constructs (construct &key with-deleted) - (:documentation "Returns all constructs which are associated with this - pointer.") - (:method ((construct PointerC) &key (with-deleted t)) - (let ((all-values (slot-p construct 'identified-construct))) - (let ((filtered-values - (if with-deleted - all-values - (remove-if #'marked-as-deleted-p all-values)))) - (map 'list #'parent-construct filtered-values))))) - - ;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpclass ReifiableConstructC(TopicMapConstructC) ((item-identifiers :initarg :item-identifiers @@ -808,18 +1016,20 @@ the identified-constructs are merged.") (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) &key (revision *TM-REVISION*)) - (let ((all-constructs - (all-identified-constructs item-identifier - :with-deleted nil))) - (cond ((find construct all-constructs) - (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) - construct)) - (all-constructs - (merge-constructs (first all-constructs) construct)) + (let ((all-ids + (map 'list #'identifier + (remove-if #'marked-as-deleted-p + (slot-p construct 'item-identifiers))))) + (cond ((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))) + (all-ids + (merge-constructs (identified-construct (first all-ids) + :revision revision) + construct)) (t (make-construct 'ItemIdAssociationC :start-revision revision @@ -909,7 +1119,7 @@ (defgeneric themes (construct &key revision) - (:documentation "Returns all topics that are not marked as deleted and are + (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") (:method ((construct ScopableC) &key (revision *TM-REVISION*)) (let ((valid-associations @@ -923,7 +1133,9 @@ scopable-construct.") (:method ((construct ScopableC) (theme-topic TopicC) &key (revision *TM-REVISION*)) - (let ((all-themes (themes construct))) + (let ((all-themes + (map 'list #'theme-topic + (remove-if #'marked-as-deleted-p (slot-p construct 'themes))))) (if (find theme-topic all-themes) (let ((theme-assoc (loop for theme-assoc in (slot-p construct 'themes)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs February 2010