Author: lgiessmann Date: Wed Feb 17 07:04:15 2010 New Revision: 192
Log: new-datamodel: added the implementation of CharacteristiC
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 Wed Feb 17 07:04:15 2010 @@ -25,12 +25,18 @@ :item-identifiers :reifier :add-item-identifier + :delete-item-identifier :add-reifier + :delete-reifier :find-item-by-revision :themes :add-theme + :delete-theme :instance-of :add-type + :delete-type + :add-parent + :delete-parent :mark-as-deleted
;;globals @@ -39,6 +45,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: implement make-construct -> symbol @@ -52,6 +60,15 @@
;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;; +(defpclass NameC (TopicMapConstructC) + () + (:documentation "A temporary emtpy class to avoid compiler-errors.")) + +(defpclass OccurrenceC (TopicMapConstructC) + () + (:documentation "A temporary emtpy class to avoid compiler-errors.")) + + (defpclass TopicC (TopicMapConstructC) () (:documentation "A temporary emtpy class to avoid compiler-errors.")) @@ -283,6 +300,126 @@ (setf (end-revision last-version) revision))))
+;;; Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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)) + (delete-construct parent-assoc))) + + +(defgeneric parent (construct &key revision) + (: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*)) + (let ((valid-associations + (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))))))) + + +(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 #'topic + (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)) + 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 + :topic 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" + 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 #'name + (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)) + return parent-assoc))) + (add-to-version-history parent-assoc :start-revision revision))) + ((not already-set-name) + (make-instance 'VariantAssociationC + :start-revision revision + :name 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" + construct parent-construct already-set-name))) + construct)) + + +(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 (topic 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 (name parent-assoc) parent-construct) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct)) + + ;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; VariantAssociationC ;;; NameAssociationC @@ -691,6 +828,19 @@ construct)))))
+(defgeneric delete-item-identifier (construct item-identifier &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) + &key (revision (error "From delete-item-identifier(): revision must be set"))) + (let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers) + when (eql (identifier ii-assoc) item-identifier) + return ii-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + (defgeneric add-reifier (construct reifier-topic &key revision) (:documentation "Adds the passed reifier-topic as reifier of the construct. If the construct is already reified by the given topic @@ -723,6 +873,19 @@ construct))))))
+(defgeneric delete-reifier (construct reifier &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct ReifiableConstructC) (reifier TopicC) + &key (revision (error "From delete-reifier(): revision must be set"))) + (let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier) + when (eql (reifier-topic reifier-assoc) reifier) + return reifier-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + ;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpclass TopicMapConstructC() () @@ -836,7 +999,7 @@ :type-topic type-topic :typable-construct construct)) (t - (error "From add-type(): ~a can't by typed by ~a since it is already typed by the topic ~a" + (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)))