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

[Lukas Giessmann]

Author: lgiessmann
Date: Thu Apr  1 19:06:02 2010
New Revision: 257

Log:
new-datamodel: added the generic "merge-constructs" --> "CharacteristicC" => "OccurrenceC" + "NameC" + "VariantC"

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 Apr  1 19:06:02 2010
@@ -3231,6 +3231,42 @@
 ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
+(defun merge-characteristics (older-parent newer-parent
+			      &key (revision *TM-REVISION*)
+			      (characteristic-type 'OccurrenceC))
+  "Deletes all characteristics of the given type from the newer-parent.
+   Merges equivalent characteristics between the newer and the older parent.
+   Adds all characteristics from the newer-parent to the older-parent or adds
+   the merged characterisitcs to the older-parent."
+  (declare (type (or TopicC NameC) older-parent newer-parent)
+	   (integer revision) (symbol characteristic-type))
+  (let ((object-name
+	 (subseq (write-to-string characteristic-type) 0
+		 (- (length (write-to-string characteristic-type)) 1))))
+    (let ((request-fun
+	   (symbol-function
+	    (find-symbol (concatenate 'string object-name "S"))))
+	  (delete-fun
+	   (symbol-function
+	    (find-symbol (concatenate 'string "DELETE-" object-name))))
+	  (add-fun
+	   (symbol-function
+	    (find-symbol (concatenate 'string "ADD-" object-name)))))
+      (dolist (newer-char (funcall request-fun newer-parent :revision revision))
+	(let ((older-char
+	       (find-if #'(lambda(char)
+			    (equivalent-constructs char newer-char
+						   :revision revision))
+			(funcall request-fun older-parent :revision revision))))
+	  (funcall delete-fun newer-parent newer-char :revision revision)
+	  (if (and newer-char older-char)
+	      (progn
+		(funcall delete-fun older-parent older-char :revision revision)
+		(funcall add-fun older-parent
+			 (merge-constructs newer-char older-char
+					   :revision revision)))
+	      (funcall add-fun older-parent newer-char)))))))
+
 
 (defmethod merge-constructs ((construct-1 ReifiableConstructC)
 			     (construct-2 ReifiableConstructC)
@@ -3258,14 +3294,38 @@
 					     :revision revision))
 			 reifier-1)))
 		(add-reifier older-construct merged-reifier :revision revision))))
-	  (when (eql (type-of newer-construct) 'ReifiableConstructC)
+	  (when (and (eql (type-of newer-construct) 'ReifiableConstructC)
+		     (eql (type-of newer-construct) 'ReifiableConstructC)
+		     (typep newer-construct 'VersionedConstructC)
+		     (typep older-construct 'VersionedConstructC))
 	    ;;If the older-construct is a "real" ReifiableConstructC and no sub
 	    ;;class the older-construct must be marked as deleted.
             ;;Sub classes are marked as deleted in the "next-method" calls.
-	    (mark-as-deleted newer-construct :revision revision))
+	    (mark-as-deleted newer-construct :revision revision)
+	    (add-to-version-history older-construct :start-revision revision))
 	  older-construct))))
 
 
+(defmethod merge-constructs ((construct-1 CharacteristicC)
+			     (construct-2 CharacteristicC)
+			     &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (unless (equivalent-constructs construct-1 construct-2 :revision revision)
+    (error "From merge-constructs(): ~a and ~a are not mergable"
+	   construct-1 construct-2))
+  (if (eql construct-1 construct-2)
+      construct-1
+      (let ((older-construct (call-next-method)))
+	(let ((newer-construct (if (eql older-construct construct-1)
+				   construct-2
+				   construct-1)))
+	  (when (and (typep construct-1 'NameC) (typep construct-2 'NameC))
+	    (merge-characteristics older-construct newer-construct
+				   :revision revision
+				   :characteristic-type 'VariantC)))
+	older-construct)))
+
+
 (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
 			     &key (revision *TM-REVISION*))
   (declare (integer revision))
@@ -3281,8 +3341,12 @@
 	  (dolist (locator (locators newer-construct :revision revision))
 	    (delete-locator newer-construct locator :revision revision)
 	    (add-locator older-construct locator :revision revision))
-	  ;;occurrences
-	  ;;names + variants
+	  (merge-characteristics older-construct newer-construct
+				 :revision revision
+				 :characteristic-type 'OccurrenceC)
+	  (merge-characteristics older-construct newer-construct
+				 :revision revision
+				 :characteristic-type 'NameC)
 	  ;;player-in-roles
 	  ;;used-as-type
 	  ;;used-as-scope