source: cl-darcs/trunk/merge.lisp

;;; Copyright (C) 2006 Magnus Henoch
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

(defgeneric merge-patches (p1 p2)
  (:documentation "Create variant of P1 that can be applied after P2.
P1 and P2 are parallel patches, i.e. they apply to the same tree.
We now want to apply P2 and then P1 to that tree.  This function
returns a version of P1 that satisfies that constraint."))

;; named patches
(defmethod merge-patches ((p1 named-patch) (p2 patch))
  (make-instance 'named-patch
                 :patchinfo (named-patch-patchinfo p1)
                 :dependencies (named-patch-dependencies p1)
                 :patch
                 (merge-patches (named-patch-patch p1) p2)))
(defmethod merge-patches ((p1 patch) (p2 named-patch))
  (merge-patches p1 (named-patch-patch p2)))

;; composite patches
(defmethod merge-patches ((p1 composite-patch) (p2 composite-patch))
  (make-instance 
   'composite-patch
   :patches
   (let ((patches1 (patches p1))
         (patches2 (patches p2)))
     (cond
       ((null patches1)
        nil)
       (t
        (labels ((mc (p1s p2s)
                   (if (null p2s)
                       p1s
                       (mc (merge-patches-after-patch p1s (car p2s)) (cdr p2s)))))
          (mc patches1 patches2)))))))
(defmethod merge-patches ((p1 composite-patch) (p2 patch))
  (make-instance 'composite-patch :patches (merge-patches-after-patch (patches p1) p2)))
(defmethod merge-patches ((p1 patch) (p2 composite-patch))
  (merge-patch-after-patches p1 (patches p2)))

(defmethod merge-patches ((p1 patch) (p2 patch))
  (or (elegant-merge p1 p2)
      (error "Couldn't merge ~A and ~A." p1 p2)))

(defun elegant-merge (p1 p2)
  ;; A piece of patch algebra.  See PatchCommute.lhs for the
  ;; explanation.
  (destructuring-bind (&optional p2-new p1-new)
      (commute p1 (invert-patch p2))
    (declare (ignore p2-new))
    (when p1-new
      (destructuring-bind (&optional p2-old p1-old)
          (commute p1-new p2)
        (declare (ignore p2-old))
        (when (equal-patch p1 p1-old t)
          p1-new)))))

(defun merge-patch-after-patches (p1 p2s)
  "Create a variant of P1 that can be applied after all of P2S.
P1 is a patch; P2S is a list of patches."
  (loop for p2s-left on p2s
     do (setf p1 (merge-patches p1 (car p2s-left))))
  p1)

(defun merge-patches-after-patch (p1s p2)
  "Create a variant of P1S that can be applied after P2.
P1S is a list of patches; P2 is a patch."
  (destructuring-bind (p1-new p2-new)
      (commute (merge-patch-after-patches p2 p1s) 
               (make-instance 'composite-patch :patches p1s))
    (declare (ignore p2-new))
    (patches p1-new)))