[isidorus-cvs] r192 - branches/new-datamodel/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Feb 17 12:04:15 UTC 2010
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)))
More information about the Isidorus-cvs
mailing list