[Cl-darcs-cvs] r7 - cl-darcs/trunk
mhenoch at common-lisp.net
mhenoch at common-lisp.net
Sat Jun 10 22:28:47 UTC 2006
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)))))))
More information about the Cl-darcs-cvs
mailing list