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

[Lukas Giessmann]

Author: lgiessmann
Date: Tue Apr  6 16:09:58 2010
New Revision: 267

Log:
new-datamodel: added "merge-constructs" --> "RoleC"

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 16:09:58 2010
@@ -155,6 +155,10 @@
 (in-package :datamodel)
 
 
+;;TODO: call delete-construct for all child-constructs that are:
+;;      *exist-in-revision-history => nil
+;;      *are not referenced by other constructs
+;;      --> iis, psis, sls, tids, names, occs, variants, roles
 ;;TODO: mark-as-deleted should call mark-as-deleted for every owned
 ;;      versioned-construct of the called construct
 ;;TODO: add: add-to-version-history (parent) to all
@@ -3636,20 +3640,40 @@
 	    (delete-construct newer-assoc))
 	  older-assoc))))
 
-;TODO: merge-constructs: RoleC (merge parents), AssociationC
 
-
-
-
-
-
-;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+(defmethod merge-constructs ((construct-1 RoleC) (construct-2 RoleC)
 			     &key (revision *TM-REVISION*))
-  (or revision)
-  (if construct-1 construct-1 construct-2))
-
-
-
-
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (declare (integer *TM-REVISION*))
+  (if (eql construct-1 construct-2)
+      construct-1
+      (let ((older-role (find-oldest-construct construct-1 construct-2)))
+	(let ((newer-role (if (eql older-role construct-1)
+			       construct-2
+			       construct-1)))
+	  (unless (strictly-equivalent-constructs construct-1 construct-2
+						  :revision revision)
+	    (error "From merge-constructs(): ~a and ~a are not mergable"
+		   construct-1 construct-2))
+	  (let ((parent-1 (parent older-role :revision revision))
+		(parent-2 (parent newer-role :revision revision)))
+	    (cond ((and parent-1 (eql parent-1 parent-2))
+		   (move-referenced-constructs newer-role older-role
+					       :revision revision)
+		   (delete-role newer-role parent-2 :revision revision)
+		   (add-role older-role parent-1 :revision revision))
+		  ((and parent-1 parent-2)
+		   (let ((active-assoc (merge-constructs parent-1 parent-2
+							 :revision revision)))
+		     (if (find older-role (roles active-assoc
+						 :revision revision))
+			 older-role
+			 newer-role)))
+		  ((or parent-1 parent-2)
+		   (let ((dst (if parent-1 older-role newer-role))
+			 (src (if parent-1 newer-role older-role)))
+		     (move-referenced-constructs src dst :revision revision)
+		     dst))
+		  (t
+		   (move-referenced-constructs newer-role older-role
+					       :revision revision)
+		   older-role)))))))
\ No newline at end of file