[Cl-darcs-cvs] r28 - cl-darcs/trunk

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Wed Jul 12 15:06:02 2006
New Revision: 28

Modified:
   cl-darcs/trunk/commute.lisp
Log:
Add commute methods for composite patches


Modified: cl-darcs/trunk/commute.lisp
==============================================================================
--- cl-darcs/trunk/commute.lisp	(original)
+++ cl-darcs/trunk/commute.lisp	Wed Jul 12 15:06:02 2006
@@ -77,3 +77,44 @@
 	 ;; In other cases, there is no failsafe way to commute the
 	 ;; patches, so we give up.
 	 nil)))))
+
+(defmethod commute ((p2 composite-patch) (p1 patch))
+  (cond
+    ;; Simple case first...
+    ((null (patches p2))
+     (list p1 p2))
+    (t
+     ;; Now, p1 was committed before all the patches in p2, and we
+     ;; want it to come after.
+     (let ((p2s (patches p2))
+	   p2s-new)
+       (loop for p in p2s
+	  do (destructuring-bind (&optional p1-new p-new)
+		 (commute p p1)
+	       (cond
+		 ((null p1-new)
+		  (return-from commute (call-next-method)))
+		 (t
+		  (setf p1 p1-new)
+		  (push p-new p2s-new)))))
+       (list p1 (make-instance 'composite-patch :patches (nreverse p2s-new)))))))
+(defmethod commute ((p2 patch) (p1 composite-patch))
+  (cond
+    ((null (patches p1))
+     (list p1 p2))
+    (t
+     ;; p2 was committed after all the patches in p1.  Thus we start
+     ;; backwards in p1, commuting p2 with each of the patches.
+     (let ((p1s (reverse (patches p1)))
+	   p1s-new)
+       (loop for p in p1s
+	  do (destructuring-bind (&optional p-new p2-new)
+		 (commute p2 p)
+	       (cond
+		 ((null p-new)
+		  (return-from commute (call-next-method)))
+		 (t
+		  (setf p2 p2-new)
+		  (push p-new p1s-new)))))
+       (list (make-instance 'composite-patch :patches p1s-new)
+	     p2)))))