Changeset 232 for branches/new-datamodel/src/model

Timestamp:

03/18/10 12:39:15 (15 years ago)

Author:

lgiessmann

Message:

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.

File:

• branches/new-datamodel/src/model/datamodel.lisp (modified) (16 diffs)

branches/new-datamodel/src/model/datamodel.lisp ¶

@@ -126 +126 @@
 ;;      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
@@ -663 +664 @@
 
 ;;; 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)
@@ -811 +817 @@
 
 ;;; 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
@@ -1092 +1106 @@
                                    :identifier topic-identifier)))
                (add-to-version-history assoc :start-revision revision))))
+      (when (typep construct 'TopicC)
+        (add-to-version-history construct :start-revision revision))
       construct)))
 
@@ -1145 +1161 @@
                                    :identifier psi)))
                (add-to-version-history assoc :start-revision revision))))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
@@ -1198 +1215 @@
                                    :identifier locator)))
                (add-to-version-history assoc :start-revision revision))))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
@@ -1248 +1266 @@
                                 :characteristic name)))
             (add-to-version-history assoc :start-revision revision))))
+    (add-to-version-history construct :start-revision revision)
     construct))
 
@@ -1297 +1316 @@
                                 :characteristic occurrence)))
             (add-to-version-history assoc :start-revision revision))))
+    (add-to-version-history construct :start-revision revision)
     construct))
 
@@ -1601 +1621 @@
 
 ;;; 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.")
@@ -1748 +1774 @@
                                 :parent-construct construct)))
             (add-to-version-history assoc :start-revision revision))))
+    (add-to-version-history construct :start-revision revision)
     construct))
 
@@ -1843 +1870 @@
                                        :parent-construct parent-construct)))
              (add-to-version-history assoc :start-revision revision)))))
+  (add-to-version-history parent-construct :start-revision revision)
   construct)
 
@@ -2000 +2028 @@
                                    :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)))
 
@@ -2050 +2082 @@
                                      :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))))
 
@@ -2138 +2174 @@
                                 :scopable-construct construct)))
             (add-to-version-history assoc :start-revision revision))))
+    (when (typep construct 'AssociationC)
+      (add-to-version-history construct :start-revision revision))
     construct))
 
@@ -2208 +2246 @@
                                    :typable-construct construct)))
                (add-to-version-history assoc :start-revision revision)))))
+    (when (typep construct 'AssociationC)
+      (add-to-version-history construct :start-revision revision))
     construct))
 
@@ -2301 +2341 @@
 
 
+(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)