[isidorus-cvs] r196 - branches/new-datamodel/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Feb 18 20:36:40 UTC 2010
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)
More information about the Isidorus-cvs
mailing list