;;; 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)))))))