Changeset 262 for branches/new-datamodel/src/model

Timestamp:

04/06/10 13:42:50 (15 years ago)

Author:

lgiessmann

Message:

new-datamodel: added "merge-constructs" for "NameC" and "VariantC"

File:

• branches/new-datamodel/src/model/datamodel.lisp (modified) (5 diffs)

branches/new-datamodel/src/model/datamodel.lisp ¶

@@ -877 +877 @@
         (vi-2 (find-version-info (list construct-2))))
     (cond ((not (or vi-1 vi-2))
-           nil)
+           construct-1)
           ((not vi-1)
            construct-2)
@@ -1031 +1031 @@
         (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)
@@ -1859 +1859 @@
         (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)
@@ -2279 +2279 @@
         (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)
@@ -3538 +3538 @@
 
 ;;; 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