Author: lgiessmann Date: Mon Apr 5 16:50:11 2010 New Revision: 260 Log: new-datamodel: added "merge-constructs" for "OccurrenceC" 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 Mon Apr 5 16:50:11 2010 @@ -3459,7 +3459,6 @@ (merge-all-constructs (append found-equivalent (list construct)))))))) - (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) (if (eql construct-1 construct-2) @@ -3482,6 +3481,34 @@ older-topic)))) +(defmethod merge-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC) + &key (revision *TM-REVISION*)) + (if (eql construct-1 construct-2) + construct-1 + (progn + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a is not mergable with ~a" + construct-1 construct-2)) + (let ((parent-1 (parent construct-1 :revision revision)) + (parent-2 (parent construct-2 :revision revision))) + (when (not (and parent-1 parent-2)) + (error "From merge-constructs():~a and ~a must be associated with a topic" + construct-1 construct-2)) + (if (and parent-1 (eql parent-1 parent-2)) + (progn + (move-identifiers construct-1 construct-2 :revision revision) + (move-referenced-constructs construct-1 construct-2 + :revision revision) + (delete-occurrence parent-1 construct-1 :revision revision) + (add-occurrence parent-1 construct-2 :revision revision)) + (let ((active-topic + (merge-constructs parent-1 parent-2 :revision revision))) + (if (find construct-1 + (occurrences active-topic :revision revision)) + construct-1 + construct-2))))))) +