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. |
---|
21 | P1 and P2 are parallel patches, i.e. they apply to the same tree. |
---|
22 | We now want to apply P2 and then P1 to that tree. This function |
---|
23 | returns 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. |
---|
75 | P1 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. |
---|
82 | P1S 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 | |
---|