1 -- Copyright (C) 2002-2003 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} 19 {-# LANGUAGE CPP #-} 20 -- , TypeOperators, PatternGuards #-} 21 22 #include "gadts.h" 23 24 module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon, 25 commuteWhatWeCanFL, commuteWhatWeCanRL, 26 genCommuteWhatWeCanRL, 27 partitionFL, partitionRL, 28 head_permutationsFL, head_permutationsRL, 29 headPermutationsFL, 30 remove_subsequenceFL, remove_subsequenceRL ) where 31 32 import Data.Maybe ( catMaybes ) 33 import Darcs.Patch.Patchy ( Commute, commute, commuteFL, commuteRL, Invert(..), invertFL, invertRL ) 34 import Darcs.Ordered 35 #include "impossible.h" 36 37 -- |split an 'FL' into "left" and "right" lists according to a predicate, using commutation as necessary. 38 -- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy 39 -- the predicate, it goes in the "right" list. 40 partitionFL :: Commute p 41 => (FORALL(u v) p C(u v) -> Bool) -- ^predicate; if true we would like the patch in the "left" list 42 -> FL p C(x y) -- ^input 'FL' 43 -> (FL p :> FL p) C(x y) -- ^"left" and "right" results 44 45 -- optimise by using an accumulating parameter to track all the "right" patches that we've found so far 46 partitionFL' :: Commute p 47 => (FORALL(u v) p C(u v) -> Bool) 48 -> RL p C(x z) -- the "right" patches found so far 49 -> FL p C(z y) 50 -> (FL p :> FL p) C(x y) 51 52 partitionFL keepleft ps = partitionFL' keepleft NilRL ps 53 54 partitionFL' _ qs NilFL = NilFL :> reverseRL qs 55 partitionFL' keepleft qs (p :>: ps) 56 | keepleft p, 57 Just (p' :> qs') <- commuteRL (qs :> p) 58 = case partitionFL' keepleft qs' ps of 59 a :> b -> p' :>: a :> b 60 | otherwise = partitionFL' keepleft (p :<: qs) ps 61 62 -- |split an 'RL' into "left" and "right" lists according to a predicate, using commutation as necessary. 63 -- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy 64 -- the predicate, it goes in the "left" list. 65 partitionRL :: Commute p 66 => (FORALL(u v) p C(u v) -> Bool) -- ^predicate; if true we would like the patch in the "right" list 67 -> RL p C(x y) -- ^input 'RL' 68 -> (RL p :> RL p) C(x y) -- ^"left" and "right" results 69 70 -- optimise by using an accumulating parameter to track all the "left" patches that we've found so far 71 partitionRL' :: Commute p 72 => (FORALL(u v) p C(u v) -> Bool) 73 -> RL p C(x z) 74 -> FL p C(z y) -- the "left" patches found so far 75 -> (RL p :> RL p) C(x y) 76 77 partitionRL keepright ps = partitionRL' keepright ps NilFL 78 79 partitionRL' _ NilRL qs = reverseFL qs :> NilRL 80 81 partitionRL' keepright (p :<: ps) qs 82 | keepright p, 83 Right (qs' :> p') <- commuteFL (p :> qs) 84 = case partitionRL' keepright ps qs' of 85 a :> b -> a :> p' :<: b 86 | otherwise = partitionRL' keepright ps (p :>: qs) 87 88 commuteWhatWeCanFL :: Commute p => (p :> FL p) C(x y) -> (FL p :> p :> FL p) C(x y) 89 commuteWhatWeCanFL (p :> x :>: xs) = 90 case commute (p :> x) of 91 Nothing -> case commuteWhatWeCanFL (x :> xs) of 92 xs1 :> x' :> xs2 -> case commuteWhatWeCanFL (p :> xs1) of 93 xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2 94 Just (x' :> p') -> case commuteWhatWeCanFL (p' :> xs) of 95 a :> p'' :> c -> x' :>: a :> p'' :> c 96 commuteWhatWeCanFL (y :> NilFL) = NilFL :> y :> NilFL 97 98 commuteWhatWeCanRL :: Commute p => (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y) 99 commuteWhatWeCanRL = genCommuteWhatWeCanRL commute 100 101 genCommuteWhatWeCanRL :: (FORALL(a b) ((p :> p) C(a b) -> Maybe ((p :> p) C(a b)))) 102 -> (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y) 103 genCommuteWhatWeCanRL com (x :<: xs :> p) = 104 case com (x :> p) of 105 Nothing -> case genCommuteWhatWeCanRL com (xs :> x) of 106 xs1 :> x' :> xs2 -> case genCommuteWhatWeCanRL com (xs2 :> p) of 107 xs1' :> p' :> xs2' -> xs1' +<+ x' :<: xs1 :> p' :> xs2' 108 Just (p' :> x') -> case genCommuteWhatWeCanRL com (xs :> p') of 109 a :> p'' :> c -> a :> p'' :> x' :<: c 110 genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL 111 112 113 removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) C(x y) -> (FL p :\/: FL p) C(x y) 114 removeCommon (xs :\/: NilFL) = xs :\/: NilFL 115 removeCommon (NilFL :\/: xs) = NilFL :\/: xs 116 removeCommon (xs :\/: ys) = rc xs (headPermutationsFL ys) 117 where rc :: (MyEq p, Commute p) => FL p C(x y) -> [(p:>FL p) C(x z)] -> (FL p :\/: FL p) C(y z) 118 rc nms ((n:>ns):_) | Just ms <- removeFL n nms = removeCommon (ms :\/: ns) 119 rc ms [n:>ns] = ms :\/: n:>:ns 120 rc ms (_:nss) = rc ms nss 121 rc _ [] = impossible -- because we already checked for NilFL case 122 123 -- | 'removeFL' @x xs@ removes @x@ from @xs@ if @x@ can be commuted to its head. 124 -- Otherwise it returns 'Nothing' 125 removeFL :: (MyEq p, Commute p) => p C(x y) -> FL p C(x z) -> Maybe (FL p C(y z)) 126 removeFL x xs = r x $ headPermutationsFL xs 127 where r :: (MyEq p, Commute p) => p C(x y) -> [(p:>FL p) C(x z)] -> Maybe (FL p C(y z)) 128 r _ [] = Nothing 129 r z ((z':>zs):zss) | IsEq <- z =\/= z' = Just zs 130 | otherwise = r z zss 131 132 -- | 'removeRL' is like 'removeFL' except with 'RL' 133 removeRL :: (MyEq p, Commute p) => p C(y z) -> RL p C(x z) -> Maybe (RL p C(x y)) 134 removeRL x xs = r x $ head_permutationsRL xs 135 where r :: (MyEq p, Commute p) => p C(y z) -> [RL p C(x z)] -> Maybe (RL p C(x y)) 136 r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs 137 | otherwise = r z zss 138 r _ _ = Nothing 139 140 -- | 'remove_subsequenceFL' @ab abc@ returns @Just c'@ where all the patches in 141 -- @ab@ have been commuted out of it, if possible. If this is not possible 142 -- for any reason (the set of patches @ab@ is not actually a subset of @abc@, 143 -- or they can't be commuted out) we return 'Nothing'. 144 remove_subsequenceFL :: (MyEq p, Commute p) => FL p C(a b) 145 -> FL p C(a c) -> Maybe (FL p C(b c)) 146 remove_subsequenceFL a b | lengthFL a > lengthFL b = Nothing 147 | otherwise = rsFL a b 148 where rsFL :: (MyEq p, Commute p) => FL p C(a b) -> FL p C(a c) -> Maybe (FL p C(b c)) 149 rsFL NilFL ys = Just ys 150 rsFL (x:>:xs) yys = removeFL x yys >>= remove_subsequenceFL xs 151 152 -- | 'remove_subsequenceRL' is like @remove_subsequenceFL@ except that it works 153 -- on 'RL' 154 remove_subsequenceRL :: (MyEq p, Commute p) => RL p C(ab abc) 155 -> RL p C(a abc) -> Maybe (RL p C(a ab)) 156 remove_subsequenceRL a b | lengthRL a > lengthRL b = Nothing 157 | otherwise = rsRL a b 158 where rsRL :: (MyEq p, Commute p) => RL p C(ab abc) -> RL p C(a abc) -> Maybe (RL p C(a ab)) 159 rsRL NilRL ys = Just ys 160 rsRL (x:<:xs) yys = removeRL x yys >>= remove_subsequenceRL xs 161 162 -- | This is a minor variant of 'headPermutationsFL' with each permutation 163 -- is simply returned as a 'FL' 164 head_permutationsFL :: Commute p => FL p C(x y) -> [FL p C(x y)] 165 head_permutationsFL ps = map (\ (x:>xs) -> x:>:xs) $ headPermutationsFL ps 166 167 -- | 'headPermutationsFL' @p:>:ps@ returns all the permutations of the list 168 -- in which one element of @ps@ is commuted past @p@ 169 -- 170 -- Suppose we have a sequence of patches 171 -- 172 -- > X h a y s-t-c k 173 -- 174 -- Suppose furthermore that the patch @c@ depends on @t@, which in turn 175 -- depends on @s@. This function will return 176 -- 177 -- > X :> h a y s t c k 178 -- > h :> X a y s t c k 179 -- > a :> X h y s t c k 180 -- > y :> X h a s t c k 181 -- > s :> X h a y t c k 182 -- > k :> X h a y s t c 183 headPermutationsFL :: Commute p => FL p C(x y) -> [(p :> FL p) C(x y)] 184 headPermutationsFL NilFL = [] 185 headPermutationsFL (p:>:ps) = 186 (p:>ps) : catMaybes (map (swapfirstFL.(p:>)) $ headPermutationsFL ps) 187 where swapfirstFL (p1:>p2:>xs) = do p2':>p1' <- commute (p1:>p2) 188 Just $ p2':>p1':>:xs 189 190 -- | 'head_permutationsRL' is like 'headPermutationsFL', except that we 191 -- operate on an 'RL' (in other words, we are pushing things to the end of a 192 -- patch sequence instead of to the beginning). 193 head_permutationsRL :: Commute p => RL p C(x y) -> [RL p C(x y)] 194 head_permutationsRL NilRL = [] 195 head_permutationsRL (p:<:ps) = 196 (p:<:ps) : catMaybes (map (swapfirstRL.(p:<:)) $ head_permutationsRL ps) 197 where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1) 198 Just $ p2':<:p1':<:xs 199 swapfirstRL _ = Nothing 200 201 instance (MyEq p, Commute p) => MyEq (FL p) where 202 a =\/= b | lengthFL a /= lengthFL b = NotEq 203 | otherwise = cmpSameLength a b 204 where cmpSameLength :: FL p C(x y) -> FL p C(x z) -> EqCheck C(y z) 205 cmpSameLength (x:>:xs) xys | Just ys <- removeFL x xys = cmpSameLength xs ys 206 cmpSameLength NilFL NilFL = IsEq 207 cmpSameLength _ _ = NotEq 208 xs =/\= ys = reverseFL xs =/\= reverseFL ys 209 210 instance (Invert p, Commute p) => Invert (FL p) where 211 invert = reverseRL . invertFL 212 identity = NilFL 213 sloppyIdentity NilFL = IsEq 214 sloppyIdentity (x:>:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs 215 sloppyIdentity _ = NotEq 216 217 instance (MyEq p, Commute p) => MyEq (RL p) where 218 unsafeCompare = bug "Buggy use of unsafeCompare on RL" 219 a =/\= b | lengthRL a /= lengthRL b = NotEq 220 | otherwise = cmpSameLength a b 221 where cmpSameLength :: RL p C(x y) -> RL p C(w y) -> EqCheck C(x w) 222 cmpSameLength (x:<:xs) xys | Just ys <- removeRL x xys = cmpSameLength xs ys 223 cmpSameLength NilRL NilRL = IsEq 224 cmpSameLength _ _ = NotEq 225 xs =\/= ys = reverseRL xs =\/= reverseRL ys 226 227 instance (Commute p, Invert p) => Invert (RL p) where 228 invert = reverseFL . invertRL 229 identity = NilRL 230 sloppyIdentity NilRL = IsEq 231 sloppyIdentity (x:<:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs 232 sloppyIdentity _ = NotEq