Author: mhenoch Date: Wed Jul 12 11:30:01 2006 New Revision: 26 Added: cl-darcs/trunk/merge.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Add merge.lisp Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Wed Jul 12 11:30:01 2006 @@ -39,6 +39,7 @@ (:file "invert-patch" :depends-on ("patch-core")) (:file "touching" :depends-on ("patch-core")) (:file "commute" :depends-on ("patch-core")) + (:file "merge" :depends-on ("patch-core")) (:file "unwind" :depends-on ("patch-core")) (:file "equal" :depends-on ("patch-core")) Added: cl-darcs/trunk/merge.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/merge.lisp Wed Jul 12 11:30:01 2006 @@ -0,0 +1,38 @@ +;;; 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) + +(defun merge-patches (p1 p2) + "Create variant of P1 that can be applied after P2. +P1 and P2 are parallel patches, i.e. they apply to the same tree. +We now want to apply P2 and then P1 to that tree. This function +returns a version of P1 that satisfies that constraint." + (or (elegant-merge p1 p2) + (error "Couldn't merge ~A and ~A." p1 p2))) + +(defun elegant-merge (p1 p2) + ;; A piece of patch algebra. See PatchCommute.lhs for the + ;; explanation. + (destructuring-bind (&optional p2-new p1-new) + (commute p1 (invert-patch p2)) + (declare (ignore p2-new)) + (when p1-new + (destructuring-bind (&optional p2-old p1-old) + (commute p1-new p2) + (declare (ignore p2-old)) + (when (equal-patch p1 p1-old t) + p1-new)))))