source: cl-darcs/trunk/unwind.lisp

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

Add license notices

File size: 4.3 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;; From PatchCommute.lhs
20
21(defmethod patch-unwindings ((patch merger-patch))
22  (if (slot-boundp patch 'unwindings)
23      (merger-unwindings patch)
24      (unwind patch)))
25
26(defmethod patch-unwindings ((patch patch))
27  (list patch))
28
29(defun unwind (patch)
30  (let* ((p1 (merger-first patch))
31         (p2 (merger-second patch))
32         (p1-unwindings (patch-unwindings p1))
33         (p2-unwindings (patch-unwindings p2)))
34    (assert (consp p1-unwindings))
35    (assert (consp p2-unwindings))
36    (setf (merger-unwindings patch)
37          (cons patch
38                (cons p1 
39                      (reconcile-unwindings patch
40                                            (cdr p1-unwindings)
41                                            (cdr p2-unwindings)))))))
42
43(defun reconcile-unwindings (p p1s p2s)
44  (cond
45    ((null p1s)
46     p2s)
47    ((null p2s)
48     p1s)
49    (t
50
51     ;; First, try to find permutations of the two lists p1s and p2s
52     ;; where the two head elements are equal.  If we found one such
53     ;; permutation, put the head element at the head of the
54     ;; unwinding, and recursively process the tails.
55     ;; "-p" stands for "permutation" here.
56     (let ((equal-heads
57            (dolist (p1s-p (all-head-permutations p1s))
58              (dolist (p2s-p (all-head-permutations p2s))
59                (when (equal-patch
60                       (car p1s-p) 
61                       (car p2s-p))
62                  (return (list p1s-p p2s-p)))))))
63       (cond
64         (equal-heads
65          (destructuring-bind (p1s-p p2s-p) equal-heads
66            (cons (car p1s-p)
67                  (reconcile-unwindings p (cdr p1s-p)
68                                        (cdr p2s-p)))))
69
70         (t
71     
72          ;; If we can't find any such permutation, take the first patch
73          ;; from either list, invert it, commute it through the other
74          ;; list, put the non-inverted patch at the head of the unwinding,
75          ;; and recursively process the tail of the one list and the
76          ;; commuted-through list.
77          (let ((p2s-c (nreverse (put-before (car p1s) (reverse p2s)))))
78            (if p2s-c
79                (cons (car p1s) (reconcile-unwindings p (cdr p1s) p2s-c))
80                (let ((p1s-c (nreverse (put-before (car p2s) (reverse p1s)))))
81                  (when p1s-c
82                    (cons (car p2s) (reconcile-unwindings p p1s-c (cdr p2s)))))))))))))
83
84(defun put-before (p1 patches)
85  "Transform PATCHES such that P1 were applied before them.
86Return nil if impossible.
87
88P1 is a patch whose context consists of PATCHES.  It is inverted,
89and commuted through PATCHES, to finally give a list of patches
90whose context consists of P1.  If any commutation fails, this
91operation fails as well."
92  (when patches
93    (destructuring-bind (&optional p2-c p1-c) (commute (invert-patch p1) (car patches))
94      (and p2-c p1-c
95           (commute p1 p2-c)
96           (let ((rest (put-before p1-c (cdr patches))))
97             (and rest (cons p2-c rest)))))))
98
99(defun all-head-permutations (ps)
100  "Return all possible permutations of PS.
101PS is a list of patches in reverse order."
102  (reverse 
103   (mapcar #'reverse 
104           (remove-duplicates 
105            (tail-permutations-normal-order ps)
106            :test (lambda (a b)
107                    (equal-list #'equal-patch a b))))))
108
109(defun tail-permutations-normal-order (ps)
110  (if (null ps)
111      ps
112      (let ((swapped-ps (swap-to-back-normal-order ps))
113            (rest (mapcar
114                   (lambda (p) (cons (car ps) p))
115                   (tail-permutations-normal-order (cdr ps)))))
116        (if swapped-ps                  ;separate () and :fail?
117            (cons swapped-ps rest)
118            rest))))
119
120(defun swap-to-back-normal-order (ps)
121  ;; If there are zero or one element, just return.
122  (if (or (null (cdr ps)) (null (cddr ps)))
123      ps
124      (let ((commuted (commute (second ps) (first ps))))
125        (when commuted                  ;XXX: separate failure?
126          (let ((rest (swap-to-back-normal-order
127                       (cons (first commuted) (cddr ps)))))
128            (when rest
129              (cons (second commuted) rest)))))))
Note: See TracBrowser for help on using the repository browser.