[isidorus-cvs] r256 - in branches/new-datamodel/src: model unit_tests

[Lukas Giessmann]

Author: lgiessmann
Date: Thu Apr  1 16:31:29 2010
New Revision: 256

Log:
new-datamodel: added the generic "merge-constructs" --> "ReifiableConstructC"

Modified:
   branches/new-datamodel/src/model/datamodel.lisp
   branches/new-datamodel/src/unit_tests/datamodel_test.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 16:31:29 2010
@@ -155,6 +155,9 @@
 (in-package :datamodel)
 
 
+;;TODO: check for duplicate identifiers after topic-creation/merge
+;;TODO: add: add-to-version-history (parent) to all
+;;      "add-<construct>"/"delete-<construct>" generics
 ;;TODO: check merge-constructs in add-topic-identifier,
 ;;      add-item-identifier/add-reifier (can merge the parent constructs
 ;;      and the parent's parent construct + the reifier constructs),
@@ -3229,18 +3232,63 @@
 
 
 
-(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC)
+(defmethod merge-constructs ((construct-1 ReifiableConstructC)
+			     (construct-2 ReifiableConstructC)
 			     &key (revision *TM-REVISION*))
   (declare (integer revision))
   (if (eql construct-1 construct-2)
       construct-1
-      (progn
-	(unless
-	    (equivalent-constructs construct-1 construct-2 :revision revision)
-	  (error "From merge-constructs(): the variants: ~a ~a are not mergable"
-		 construct-1 construct-2))
-	;;...
-	)))
+      (let ((older-construct (find-oldest-construct construct-1 construct-2)))
+	(let ((newer-construct (if (eql older-construct construct-1)
+				   construct-2
+				   construct-1)))
+	  (dolist (ii (item-identifiers newer-construct :revision revision))
+	    (delete-item-identifier newer-construct ii :revision revision)
+	    (add-item-identifier older-construct ii :revision revision))
+	  (let ((reifier-1 (reifier newer-construct :revision revision))
+		(reifier-2 (reifier older-construct :revision revision)))
+	    (when reifier-1
+	      (delete-reifier newer-construct reifier-1 :revision revision)
+	      (let ((merged-reifier
+		     (if reifier-2
+			 (progn
+			   (delete-reifier older-construct reifier-2
+					   :revision revision)
+			   (merge-constructs reifier-1 reifier-2
+					     :revision revision))
+			 reifier-1)))
+		(add-reifier older-construct merged-reifier :revision revision))))
+	  (when (eql (type-of newer-construct) 'ReifiableConstructC)
+	    ;;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))
+	  older-construct))))
+
+
+(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
+			     &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (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)))
+	  (dolist (psi (psis newer-construct :revision revision))
+	    (delete-psi newer-construct psi :revision revision)
+	    (add-psi older-construct psi :revision revision))
+	  (dolist (locator (locators newer-construct :revision revision))
+	    (delete-locator newer-construct locator :revision revision)
+	    (add-locator older-construct locator :revision revision))
+	  ;;occurrences
+	  ;;names + variants
+	  ;;player-in-roles
+	  ;;used-as-type
+	  ;;used-as-scope
+	  ;;reified-construct
+	  ;;in-topicmaps
+	  ))))
 
 
 

Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp	(original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp	Thu Apr  1 16:31:29 2010
@@ -77,7 +77,6 @@
 	   :test-find-oldest-construct))
 
 
-;;TODO: test equivalent-constructs
 ;;TODO: test merge-constructs