Author: mhenoch Date: Sat Jun 10 18:28:47 2006 New Revision: 7 Added: cl-darcs/trunk/unwind.lisp Modified: cl-darcs/trunk/apply-patch.lisp cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/commute.lisp cl-darcs/trunk/invert-patch.lisp cl-darcs/trunk/patch-core.lisp cl-darcs/trunk/read-patch.lisp Log: Start hacking merger unwinding Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Sat Jun 10 18:28:47 2006 @@ -319,4 +319,8 @@ (when (null undo) (error "Don't know how to undo ~A." patch)) - (apply-patch undo repodir))) + (apply-patch undo repodir) + + ;; After this comes "glump". As long as version is "0.0", it + ;; doesn't do anything. + (assert (string= (merger-version patch) "0.0")))) Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sat Jun 10 18:28:47 2006 @@ -38,6 +38,8 @@ (:file "invert-patch" :depends-on ("patch-core")) (:file "touching" :depends-on ("patch-core")) (:file "commute" :depends-on ("patch-core")) + (:file "unwind" :depends-on ("patch-core")) + (:file "equal" :depends-on ("patch-core")) ;; Franz' inflate implementation #-allegro (:file "ifstar") Modified: cl-darcs/trunk/commute.lisp ============================================================================== --- cl-darcs/trunk/commute.lisp (original) +++ cl-darcs/trunk/commute.lisp Sat Jun 10 18:28:47 2006 @@ -1,12 +1,12 @@ (in-package :darcs) -(defgeneric commute-patches (p2 p1) +(defgeneric commute (p2 p1) (:documentation "Attempt to commute the patches P2 and P1. Return a list, (P1-NEW P2-NEW), such that applying P2-NEW and then P1-NEW has the same effect as applying P1 and then P2. If commutations fails, return nil.")) -(defmethod commute-patches :around ((p2 file-patch) (p1 file-patch)) +(defmethod commute :around ((p2 file-patch) (p1 file-patch)) "If P1 and P2 change different files, commutation is trivial." (let ((p1-file (patch-filename p1)) (p2-file (patch-filename p2))) @@ -14,7 +14,7 @@ (list p1 p2) (call-next-method)))) -(defmethod commute-patches ((p2 hunk-patch) (p1 hunk-patch)) +(defmethod commute ((p2 hunk-patch) (p1 hunk-patch)) "Attempt to commute the two hunk patches P1 and P2." (assert (equal (patch-filename p1) (patch-filename p2))) (with-accessors ((line1 hunk-line-number) Modified: cl-darcs/trunk/invert-patch.lisp ============================================================================== --- cl-darcs/trunk/invert-patch.lisp (original) +++ cl-darcs/trunk/invert-patch.lisp Sat Jun 10 18:28:47 2006 @@ -84,3 +84,11 @@ (defmethod invert-patch ((patch rm-dir-patch)) (make-instance 'add-dir-patch)) +(defmethod invert-patch ((patch merger-patch)) + (make-instance 'merger-patch + :version (merger-version patch) + :first (merger-first patch) + :second (merger-second patch) + :undo (merger-undo patch) + :unwindings (unwind patch) + :inverted (not (merger-inverted patch)))) Modified: cl-darcs/trunk/patch-core.lisp ============================================================================== --- cl-darcs/trunk/patch-core.lisp (original) +++ cl-darcs/trunk/patch-core.lisp Sat Jun 10 18:28:47 2006 @@ -33,7 +33,7 @@ ((patches :accessor patches :initarg :patches :initform ()))) (defclass file-patch (patch) - ((filename :accessor patch-filename :initarg :filename)) + ((filename :accessor patch-filename :initarg :filename :type pathname)) (:documentation "Base class for patches affecting a single file.")) (defmethod print-object ((patch file-patch) stream) @@ -75,9 +75,9 @@ (:documentation "A patch that changes a binary file.")) (defclass token-replace-patch (file-patch) - ((regexp :accessor token-regexp :initarg :regexp) - (old-token :accessor old-token :initarg :old-token) - (new-token :accessor new-token :initarg :new-token)) + ((regexp :accessor token-regexp :initarg :regexp :type 'string) + (old-token :accessor old-token :initarg :old-token :type 'string) + (new-token :accessor new-token :initarg :new-token :type 'string)) (:documentation "A patch that replaces one token with another.")) (defmethod print-object ((patch token-replace-patch) stream) @@ -161,8 +161,9 @@ (defmethod print-object ((patch merger-patch) stream) (if *print-readably* (call-next-method) - (format stream "#<~A ~A: ~A ~A>" + (format stream "#<~A ~:[(inverted) ~;~]~A: ~A ~A>" (type-of patch) + (merger-inverted patch) (merger-version patch) (merger-first patch) (merger-second patch)))) Modified: cl-darcs/trunk/read-patch.lisp ============================================================================== --- cl-darcs/trunk/read-patch.lisp (original) +++ cl-darcs/trunk/read-patch.lisp Sat Jun 10 18:28:47 2006 @@ -250,25 +250,26 @@ (let ((p1 (read-patch stream)) (p2 (read-patch stream))) (read-token stream) ; #\) - (let* ((is-merger1 (typep p1 'merger-patch)) - (is-merger2 (typep p2 'merger-patch)) - (undo - (cond - ((and is-merger1 is-merger2) - ;; TBD - nil - ) - ((and (not is-merger1) (not is-merger2)) - (invert-patch p1)) - ((and is-merger1 (not is-merger2)) - (make-instance 'composite-patch)) ;empty patch - ((and (not is-merger1) is-merger2) - (make-instance 'composite-patch - :patches (list (invert-patch p1) - (merger-undo p2))))))) - (make-instance 'merger-patch - :version version :first p1 :second p2 - :inverted inverted :undo undo))))) + (let ((merger (make-instance 'merger-patch + :version version :first p1 :second p2 + :inverted inverted))) + (let* ((is-merger1 (typep p1 'merger-patch)) + (is-merger2 (typep p2 'merger-patch))) + (setf (merger-undo merger) + (cond + ((and is-merger1 is-merger2) + (make-instance 'composite-patch + :patches (mapcar #'invert-patch + (cdr (unwind merger))))) + ((and (not is-merger1) (not is-merger2)) + (invert-patch p1)) + ((and is-merger1 (not is-merger2)) + (make-instance 'composite-patch)) ;empty patch + ((and (not is-merger1) is-merger2) + (make-instance 'composite-patch + :patches (list (invert-patch p1) + (merger-undo p2))))))) + merger)))) (defun read-token-replace (stream) "Read a token replacing patch." Added: cl-darcs/trunk/unwind.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/unwind.lisp Sat Jun 10 18:28:47 2006 @@ -0,0 +1,112 @@ +(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." + (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)))))))