source: cl-darcs/trunk/unwind.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)

;; From PatchCommute.lhs

(defmethod patch-unwindings ((patch merger-patch))
  (if (slot-boundp patch 'unwindings)
      (merger-unwindings patch)
      (unwind patch)))

(defmethod patch-unwindings ((patch patch))
  (list patch))

(defun unwind (patch)
  (let* ((p1 (merger-first patch))
         (p2 (merger-second patch))
         (p1-unwindings (patch-unwindings p1))
         (p2-unwindings (patch-unwindings p2)))
    (assert (consp p1-unwindings))
    (assert (consp p2-unwindings))
    (setf (merger-unwindings patch)
          (cons patch
                (cons p1 
                      (reconcile-unwindings patch
                                            (cdr p1-unwindings)
                                            (cdr p2-unwindings)))))))

(defun reconcile-unwindings (p p1s p2s)
  (cond
    ((null p1s)
     p2s)
    ((null p2s)
     p1s)
    (t

     ;; First, try to find permutations of the two lists p1s and p2s
     ;; where the two head elements are equal.  If we found one such
     ;; permutation, put the head element at the head of the
     ;; unwinding, and recursively process the tails.
     ;; "-p" stands for "permutation" here.
     (let ((equal-heads
            (dolist (p1s-p (all-head-permutations p1s))
              (dolist (p2s-p (all-head-permutations p2s))
                (when (equal-patch
                       (car p1s-p) 
                       (car p2s-p))
                  (return (list p1s-p p2s-p)))))))
       (cond
         (equal-heads
          (destructuring-bind (p1s-p p2s-p) equal-heads
            (cons (car p1s-p)
                  (reconcile-unwindings p (cdr p1s-p)
                                        (cdr p2s-p)))))

         (t
     
          ;; If we can't find any such permutation, take the first patch
          ;; from either list, invert it, commute it through the other
          ;; list, put the non-inverted patch at the head of the unwinding,
          ;; and recursively process the tail of the one list and the
          ;; commuted-through list.
          (let ((p2s-c (nreverse (put-before (car p1s) (reverse p2s)))))
            (if p2s-c
                (cons (car p1s) (reconcile-unwindings p (cdr p1s) p2s-c))
                (let ((p1s-c (nreverse (put-before (car p2s) (reverse p1s)))))
                  (when p1s-c
                    (cons (car p2s) (reconcile-unwindings p p1s-c (cdr p2s)))))))))))))

(defun put-before (p1 patches)
  "Transform PATCHES such that P1 were applied before them.
Return nil if impossible.

P1 is a patch whose context consists of PATCHES.  It is inverted,
and commuted through PATCHES, to finally give a list of patches
whose context consists of P1.  If any commutation fails, this
operation fails as well."
  (when patches
    (destructuring-bind (&optional p2-c p1-c) (commute (invert-patch p1) (car patches))
      (and p2-c p1-c
           (commute p1 p2-c)
           (let ((rest (put-before p1-c (cdr patches))))
             (and rest (cons p2-c rest)))))))

(defun all-head-permutations (ps)
  "Return all possible permutations of PS.
PS is a list of patches in reverse order."
  (reverse 
   (mapcar #'reverse 
           (remove-duplicates 
            (tail-permutations-normal-order ps)
            :test (lambda (a b)
                    (equal-list #'equal-patch a b))))))

(defun tail-permutations-normal-order (ps)
  (if (null ps)
      ps
      (let ((swapped-ps (swap-to-back-normal-order ps))
            (rest (mapcar
                   (lambda (p) (cons (car ps) p))
                   (tail-permutations-normal-order (cdr ps)))))
        (if swapped-ps                  ;separate () and :fail?
            (cons swapped-ps rest)
            rest))))

(defun swap-to-back-normal-order (ps)
  ;; If there are zero or one element, just return.
  (if (or (null (cdr ps)) (null (cddr ps)))
      ps
      (let ((commuted (commute (second ps) (first ps))))
        (when commuted                  ;XXX: separate failure?
          (let ((rest (swap-to-back-normal-order
                       (cons (first commuted) (cddr ps)))))
            (when rest
              (cons (second commuted) rest)))))))