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

[Lukas Giessmann]

Author: lgiessmann
Date: Fri Apr 23 15:51:28 2010
New Revision: 287

Log:
new-datamodel: fixed a versioningproblem in "merge-constructs" --> CharacteristicC

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	Fri Apr 23 15:51:28 2010
@@ -159,9 +159,6 @@
 (in-package :datamodel)
 
 
-;;TODO: replace add-<xy> + add-parent in all merge-constructs where the
-;;      characteristics are readded to make sure they are added to the current
-;;      version --> collidates with merge-if-equivalent!!! in merge-constructs
 ;;TODO: adapt changes-lisp
 ;;TODO: check merge-constructs in add-topic-identifier,
 ;;      add-item-identifier/add-reifier (can merge the parent constructs
@@ -4067,6 +4064,18 @@
 					       :revision revision)
 		   (delete-characteristic parent-2 newer-char
 					  :revision revision)
+		   (let ((c-assoc
+			  (find-if
+			   #'(lambda(c-assoc)
+			       (and (eql (characteristic c-assoc) older-char)
+				    (eql (parent-construct c-assoc) parent-1)))
+			   (cond ((typep older-char 'OccurrenceC)
+				  (slot-p parent-1 'occurrences))
+				 ((typep older-char 'NameC)
+				  (slot-p parent-1 'names))
+				 ((typep older-char 'VariantC)
+				  (slot-p parent-1 'variants))))))
+		     (add-to-version-history c-assoc :start-revision revision))
 		   older-char)
 		  ((and parent-1 parent-2)
 		   (let ((active-parent (merge-constructs parent-1 parent-2
@@ -4185,7 +4194,8 @@
 			       (and (eql (role r-assoc) older-role)
 				    (eql (parent-construct r-assoc) parent-1)))
 			   (slot-p parent-1 'roles))))
-		     (add-to-version-history r-assoc :start-revision revision)))
+		     (add-to-version-history r-assoc :start-revision revision)
+		     older-role))
 		  ((and parent-1 parent-2)
 		   (let ((active-assoc (merge-constructs parent-1 parent-2
 							 :revision revision)))