source: cl-darcs/trunk/merge.lisp

Last change on this file was 29, checked in by Magnus Henoch, 16 years ago

Implement merge-patches-after-patch

File size: 3.1 KB
Line 
1;;; Copyright (C) 2006 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) any later version.
7;;;
8;;; This program is distributed in the hope that it will be useful,
9;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11;;; General Public License for more details.
12;;;
13;;; You should have received a copy of the GNU General Public License
14;;; along with this program; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19(defgeneric merge-patches (p1 p2)
20  (:documentation "Create variant of P1 that can be applied after P2.
21P1 and P2 are parallel patches, i.e. they apply to the same tree.
22We now want to apply P2 and then P1 to that tree.  This function
23returns a version of P1 that satisfies that constraint."))
24
25;; named patches
26(defmethod merge-patches ((p1 named-patch) (p2 patch))
27  (make-instance 'named-patch
28                 :patchinfo (named-patch-patchinfo p1)
29                 :dependencies (named-patch-dependencies p1)
30                 :patch
31                 (merge-patches (named-patch-patch p1) p2)))
32(defmethod merge-patches ((p1 patch) (p2 named-patch))
33  (merge-patches p1 (named-patch-patch p2)))
34
35;; composite patches
36(defmethod merge-patches ((p1 composite-patch) (p2 composite-patch))
37  (make-instance 
38   'composite-patch
39   :patches
40   (let ((patches1 (patches p1))
41         (patches2 (patches p2)))
42     (cond
43       ((null patches1)
44        nil)
45       (t
46        (labels ((mc (p1s p2s)
47                   (if (null p2s)
48                       p1s
49                       (mc (merge-patches-after-patch p1s (car p2s)) (cdr p2s)))))
50          (mc patches1 patches2)))))))
51(defmethod merge-patches ((p1 composite-patch) (p2 patch))
52  (make-instance 'composite-patch :patches (merge-patches-after-patch (patches p1) p2)))
53(defmethod merge-patches ((p1 patch) (p2 composite-patch))
54  (merge-patch-after-patches p1 (patches p2)))
55
56(defmethod merge-patches ((p1 patch) (p2 patch))
57  (or (elegant-merge p1 p2)
58      (error "Couldn't merge ~A and ~A." p1 p2)))
59
60(defun elegant-merge (p1 p2)
61  ;; A piece of patch algebra.  See PatchCommute.lhs for the
62  ;; explanation.
63  (destructuring-bind (&optional p2-new p1-new)
64      (commute p1 (invert-patch p2))
65    (declare (ignore p2-new))
66    (when p1-new
67      (destructuring-bind (&optional p2-old p1-old)
68          (commute p1-new p2)
69        (declare (ignore p2-old))
70        (when (equal-patch p1 p1-old t)
71          p1-new)))))
72
73(defun merge-patch-after-patches (p1 p2s)
74  "Create a variant of P1 that can be applied after all of P2S.
75P1 is a patch; P2S is a list of patches."
76  (loop for p2s-left on p2s
77     do (setf p1 (merge-patches p1 (car p2s-left))))
78  p1)
79
80(defun merge-patches-after-patch (p1s p2)
81  "Create a variant of P1S that can be applied after P2.
82P1S is a list of patches; P2 is a patch."
83  (destructuring-bind (p1-new p2-new)
84      (commute (merge-patch-after-patches p2 p1s) 
85               (make-instance 'composite-patch :patches p1s))
86    (declare (ignore p2-new))
87    (patches p1-new)))
88
Note: See TracBrowser for help on using the repository browser.