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

[Lukas Giessmann]

Author: lgiessmann
Date: Tue Apr  6 09:42:50 2010
New Revision: 262

Log:
new-datamodel: added "merge-constructs" for "NameC" and "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	Tue Apr  6 09:42:50 2010
@@ -876,7 +876,7 @@
   (let ((vi-1 (find-version-info (list construct-1)))
 	(vi-2 (find-version-info (list construct-2))))
     (cond ((not (or vi-1 vi-2))
-	   nil)
+	   construct-1)
 	  ((not vi-1)
 	   construct-2)
 	  ((not vi-2)
@@ -1030,7 +1030,7 @@
   (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct)))
 	(vi-2 (find-version-info (slot-p construct-2 'identified-construct))))
     (cond ((not (or vi-1 vi-2))
-	   nil)
+	   construct-1)
 	  ((not vi-1)
 	   construct-2)
 	  ((not vi-2)
@@ -1858,7 +1858,7 @@
   (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
 	(vi-2 (find-version-info (slot-p construct-2 'parent))))
     (cond ((not (or vi-1 vi-2))
-	   nil)
+	   construct-1)
 	  ((not vi-1)
 	   construct-2)
 	  ((not vi-2)
@@ -2278,7 +2278,7 @@
   (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
 	(vi-2 (find-version-info (slot-p construct-2 'parent))))
     (cond ((not (or vi-1 vi-2))
-	   nil)
+	   construct-1)
 	  ((not vi-1)
 	   construct-2)
 	  ((not vi-2)
@@ -3536,4 +3536,83 @@
 
 
 
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
\ No newline at end of file
+;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC)
+			     &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (if (eql construct-1 construct-2)
+      construct-1
+      (let ((older-var (find-oldest-construct construct-1 construct-2)))
+	(let ((newer-var (if (eql older-var construct-1)
+			     construct-2
+			     construct-1)))
+	  (let ((parent-1 (parent older-var :revision revision))
+		(parent-2 (parent newer-var :revision revision)))
+	    (unless (strictly-equivalent-constructs construct-1 construct-2
+						    :revision revision)
+	      (error "From merge-constructs(): ~a and ~a are not mergable"
+		     construct-1 construct-2))
+	    (cond ((and parent-1 parent-2)
+		   (let ((active-parent
+			  (merge-constructs parent-1 parent-2
+					    :revision revision)))
+		     (let ((all-names (names active-parent :revision revision)))
+		       (if (find-if #'(lambda(name)
+					(find older-var (variants name :revision
+								  revision)))
+				    all-names)
+			   older-var
+			   newer-var))))
+		  ((or parent-1 parent-2)
+		   (let ((dst (if parent-1 older-var newer-var))
+			 (src (if parent-1 newer-var older-var)))
+		     (move-identifiers src dst :revision revision)
+		     (move-referenced-constructs src dst :revision revision)
+		     dst))
+		  (t
+		   (move-identifiers newer-var older-var :revision revision)
+		   (move-referenced-constructs newer-var older-var
+					       :revision revision)
+		   older-var)))))))
+
+
+(defmethod merge-constructs ((construct-1 NameC) (construct-2 NameC)
+			     &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (if (eql construct-1 construct-2)
+      construct-1
+      (let ((older-name (find-oldest-construct construct-1 construct-2)))
+	(let ((newer-name (if (eql older-name construct-1)
+			      construct-2
+			      construct-1)))
+	  (let ((parent-1 (parent older-name :revision revision))
+		(parent-2 (parent newer-name :revision revision)))
+	    (unless (strictly-equivalent-constructs construct-1 construct-2
+						    :revision revision)
+	      (error "From merge-constructs(): ~a and ~a are not mergable"
+		     construct-1 construct-2))
+	    (cond ((and parent-1 parent-2)
+		   (let ((active-parent (merge-constructs parent-1 parent-2
+							  :revision revision)))
+		     (if (find older-name (names active-parent
+						 :revision revision))
+			 older-name
+			 newer-name)))
+		  ((or parent-1 parent-2)
+		   (let ((dst (if parent-1 older-name newer-name))
+			 (src (if parent-1 newer-name older-name)))
+		     (move-identifiers src dst :revision revision)
+		     (move-referenced-constructs src dst :revision revision)
+		     (move-variants src dst :revision revision)
+		     dst))
+		  (t
+		   (move-identifiers newer-name older-name :revision revision)
+		   (move-referenced-constructs newer-name older-name
+					       :revision revision)
+		   (move-variants newer-name older-name :revision revision)
+		   older-name)))))))
+
+
+;TODO: --> include move-yx in move-referenced-constructs
\ No newline at end of file