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)