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

[Lukas Giessmann]

Author: lgiessmann
Date: Thu Mar 18 08:39:15 2010
New Revision: 232

Log:
new-datamodel: added the helper function "make-characteristic" for "make-construct"; fixed a bug in all add-<construct> generics that are defined for "VersionedConstruct"s, so currently adding a charactersistic or pointer calls add-to-version-history with the given revision for the called parent-construct and signals that the parent-construct was changed in the given revision.

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 Mar 18 08:39:15 2010
@@ -125,7 +125,8 @@
 ;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier,
 ;;      add-psi, add-locator
 
-
+;;TODO: all add-<construct> methods hve to add an version info to the
+;;      owner-construct
 ;;TODO: finalize add-reifier
 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
 ;;      initarg in make-construct
@@ -662,6 +663,11 @@
 
 
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric get-all-characteristics (parent-construct characteristic-symbol)
+  (:documentation "Returns all characterisitcs of the passed type the parent
+                   construct was ever associated with."))
+
+
 (defgeneric equivalent-construct (construct &key start-revision
 					    &allow-other-keys)
   (:documentation "Returns t if the passed construct is equivalent to the passed
@@ -810,6 +816,14 @@
   
 
 ;;; TopicMapconstructC
+(defmethod get-all-characteristics ((parent-construct TopicC)
+				    (characteristic-symbol symbol))
+  (cond ((OccurrenceC-p characteristic-symbol)
+	 (map 'list #'characteristic (slot-p parent-construct 'occurrences)))
+	((NameC-p characteristic-symbol)
+	 (map 'list #'characteristic (slot-p parent-construct 'names)))))
+
+
 (defgeneric TopicMapConstructC-p (class-symbol)
   (:documentation "Returns t if the passed class is equal to TopicMapConstructC
                    or one of its subtypes.")
@@ -1091,6 +1105,8 @@
 				   :parent-construct construct
 				   :identifier topic-identifier)))
 	       (add-to-version-history assoc :start-revision revision))))
+      (when (typep construct 'TopicC)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -1144,6 +1160,7 @@
 				   :parent-construct construct
 				   :identifier psi)))
 	       (add-to-version-history assoc :start-revision revision))))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
 
@@ -1197,6 +1214,7 @@
 				   :parent-construct construct
 				   :identifier locator)))
 	       (add-to-version-history assoc :start-revision revision))))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
 
@@ -1247,6 +1265,7 @@
 				:parent-construct construct
 				:characteristic name)))
 	    (add-to-version-history assoc :start-revision revision))))
+    (add-to-version-history construct :start-revision revision)
     construct))
 
 
@@ -1296,6 +1315,7 @@
 				:parent-construct construct
 				:characteristic occurrence)))
 	    (add-to-version-history assoc :start-revision revision))))
+    (add-to-version-history construct :start-revision revision)
     construct))
 
 
@@ -1600,6 +1620,12 @@
 
 
 ;;; NameC
+(defmethod get-all-characteristics ((parent-construct NameC)
+				    (characteristic-symbol symbol))
+  (when (VariantC-p characteristic-symbol)
+    (map 'list #'characteristic (slot-p parent-construct 'variants))))
+
+
 (defgeneric NameC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to Name.")
   (:method ((class-symbol symbol))
@@ -1747,6 +1773,7 @@
 				:role role
 				:parent-construct construct)))
 	    (add-to-version-history assoc :start-revision revision))))
+    (add-to-version-history construct :start-revision revision)
     construct))
 
 
@@ -1842,6 +1869,7 @@
 				       :role construct
 				       :parent-construct parent-construct)))
 	     (add-to-version-history assoc :start-revision revision)))))
+  (add-to-version-history parent-construct :start-revision revision)
   construct)
 
 
@@ -1999,6 +2027,10 @@
 				   :parent-construct construct
 				   :identifier item-identifier)))
 	       (add-to-version-history assoc :start-revision revision))))
+      (when (or (typep construct 'TopicC)
+		(typep construct 'AssociationC)
+		(typep construct 'TopicMapC))
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -2049,6 +2081,10 @@
 				     :reifiable-construct construct
 				     :reifier-topic merged-reifier-topic)))
 		 (add-to-version-history assoc :start-revision revision))))
+	(when (or (typep construct 'TopicC)
+		  (typep construct 'AssociationC)
+		  (typep construct 'TopicMapC))
+	  (add-to-version-history construct :start-revision revision))
 	construct))))
 
 
@@ -2137,6 +2173,8 @@
 				:theme-topic theme-topic
 				:scopable-construct construct)))
 	    (add-to-version-history assoc :start-revision revision))))
+    (when (typep construct 'AssociationC)
+      (add-to-version-history construct :start-revision revision))
     construct))
 
 
@@ -2207,6 +2245,8 @@
 				   :type-topic type-topic
 				   :typable-construct construct)))
 	       (add-to-version-history assoc :start-revision revision)))))
+    (when (typep construct 'AssociationC)
+      (add-to-version-history construct :start-revision revision))
     construct))
 
 
@@ -2300,11 +2340,53 @@
       construct)))
 
 
+(defun make-characteristic (class-symbol charvalue
+			    &key (start-revision *TM-REVISION*)
+			    (datatype *xml-string*) (themes nil)
+			    (instance-of nil) (variants nil)
+			    (parent-construct nil))
+  "Returns a characteristic object with the passed parameters.
+   If an equivalent construct has already existed this one is returned.
+   To check if there is existing an equivalent construct the parameter
+   parent-construct must be set."
+  (declare (symbol class-symbol) (string charvalue) (integer start-revision)
+	   (list themes variants)
+	   (type (or null string) datatype)
+	   (type (or null TopicC) instance-of)
+	   (type (or null TopicC NameC) parent-construct))
+  (let ((characteristic
+	 (let ((existing-characteristic
+		(when parent-construct
+		  (remove-if
+		   #'null
+		   (map 'list #'(lambda(existing-characteristic)
+				  (when (equivalent-construct
+					 existing-characteristic
+					 :start-revision start-revision
+					 :datatype datatype :themes themes
+					 :instance-of instance-of)
+				    existing-characteristic))
+			(get-all-characteristics parent-construct
+						 class-symbol))))))
+	   (if existing-characteristic
+	       existing-characteristic
+	       (make-instance class-symbol :charvalue charvalue
+			      :datatype datatype)))))
+    (dolist (theme themes)
+      (add-theme characteristic theme :revision start-revision))
+    (when instance-of
+      (add-type characteristic instance-of :revision start-revision))
+    (dolist (variant variants)
+      (add-variant characteristic variant :revision start-revision))
+    (when parent-construct
+      (add-parent characteristic parent-construct :revision start-revision))))
+
 
 (defun make-pointer (class-symbol uri
 		     &key (start-revision *TM-REVISION*) (xtm-id nil)
 		     (identified-construct nil))
-  "Returns a pointer object with the specified parameters."
+  "Returns a pointer object with the specified parameters.
+   If an equivalen construct has already existed this one is returned."
   (declare (symbol class-symbol) (string uri) (integer start-revision)
 	   (type (or null string) xtm-id)
 	   (type (or null ReifiableconstructC)))