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