[isidorus-cvs] r189 - branches/new-datamodel/src/model

[Lukas Giessmann]

Author: lgiessmann
Date: Tue Feb 16 06:54:16 2010
New Revision: 189

Log:
new-datamodel: added the implementation of TypableC

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	Tue Feb 16 06:54:16 2010
@@ -168,6 +168,7 @@
 (defpclass VersionedConstructC()
   ((versions :initarg :versions
 	     :accessor versions
+	     :inherit t
 	     :associate (VersionInfoC versioned-construct)
 	     :documentation "Version infos for former versions of this base
                              class.")))
@@ -439,6 +440,7 @@
 (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
@@ -513,12 +515,14 @@
 (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)))
+			 :associate (PointerAssociationC identifier)
+			 :inherit t))
   (:documentation "An abstract base class for all pointers."))
 
 
@@ -550,10 +554,12 @@
 (defpclass ReifiableConstructC(TopicMapConstructC)
   ((item-identifiers :initarg :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)
+	    :inherit t
 	    :documentation "A relation to a reifier-topic."))
   (:documentation "Reifiable constructs as per TMDM."))
 
@@ -656,26 +662,26 @@
 
 ;;; ScopableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass ScopableC()
-  ((themes :initarg :themes
-	   :associate (ScopeAssociationC scopable-construct)
+  ((themes :associate (ScopeAssociationC scopable-construct)
 	   :inherit t
-	   :documentation "Contains all Association-objects that contain the
+	   :documentation "Contains all association-objects that contain the
                            actual scope-topics."))
   (:documentation "An abstract base class for all constructs that are scoped."))
 
 
 (defmethod delete-construct :before ((construct ScopableC))
   "Deletes all ScopeAssociationCs that are associated with the given object."
-  (dolist (theme (themes construct))
+  (dolist (theme (slot-p construct 'themes))
     (delete-construct theme)))
 
 
-(defgeneric themes (construct)
+(defgeneric themes (construct &key revision)
   (:documentation "Returns all topics that are not marked as deleted and are
                    as a scope for the given topic.")
-  (:method ((construct ScopableC))
+  (:method ((construct ScopableC) &key (revision *TM-REVISION*))
     (let ((valid-associations
-	   (remove-if-not #'marked-as-deleted-p (slot-p construct 'themes))))
+	   (filter-slot-value-by-revision construct 'themes
+					  :start-revision revision)))
       (map 'list #'theme-topic valid-associations))))
 
 
@@ -712,5 +718,68 @@
 
 
 ;;; TypableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;TODO: implement a TypeAssociationC-class -> extend the uml schema
-;;      --> error if there are more than one types on one revision
\ No newline at end of file
+(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."))
+
+
+(defmethod delete-construct :before ((construct TypableC))
+  "Deletes all TypeAssociationCs that are associated with this object."
+  (dolist (type (slot-p construct 'instance-of))
+    (delete-construct type)))
+
+
+(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*))
+    (let ((valid-associations
+	   (filter-slot-value-by-revision construct 'instance-of
+					  :start-revision revision)))
+      (when valid-associations
+	(type-topic (first valid-associations))))))
+
+
+(defgeneric add-type (construct type-topic &key revision)
+  (:documentation "Add the passed type-topic as type to the given
+                   typed construct if there is no other type-topic
+                   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))))
+      (cond ((and already-set-type
+		  (eql (first already-set-type) type-topic))
+	     (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)
+	     (make-instance 'TypeAssociationC
+			    :start-revision revision
+			    :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"
+		    construct type-topic already-set-type)))
+      construct)))
+
+
+(defgeneric delete-type (construct type-topic &key revision)
+  (:documentation "Deletes the passed type by marking it's association as
+                   deleted in the passed revision.")
+  (:method ((construct TypableC) (type-topic TopicC)
+	    &key (revision (error "From delete-type(): revision must be set")))
+    (let ((assoc-to-delete
+	   (loop for type-assoc in (slot-p construct 'instance-of)
+	      when (eql (type-topic type-assoc) type-topic)
+	      return type-assoc)))
+      (when assoc-to-delete
+	(mark-as-deleted assoc-to-delete :revision revision))
+      construct)))
\ No newline at end of file