src/Darcs/Patch/Permutations.lhs

   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
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
  21 {-# LANGUAGE CPP #-}
  22 -- , TypeOperators, PatternGuards #-}
  23
  24 #include "gadts.h"
  25
  26 module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon,
  27                                   commuteWhatWeCanFL, commuteWhatWeCanRL,
  28                                   genCommuteWhatWeCanRL,
  29                                   partitionFL, partitionRL,
  30                                   head_permutationsFL, head_permutationsRL,
  31                                   headPermutationsFL,
  32                                   remove_subsequenceFL, remove_subsequenceRL ) where
  33
  34 import Data.Maybe ( catMaybes )
  35 import Darcs.Patch.Patchy ( Commute, commute, commuteFL, commuteRL, Invert(..), invertFL, invertRL )
  36 import Darcs.Ordered
  37 #include "impossible.h"
  38 \end{code}
  39
  40 \begin{code}
  41
  42 -- |split an 'FL' into "left" and "right" lists according to a predicate, using commutation as necessary.
  43 -- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy
  44 -- the predicate, it goes in the "right" list.
  45 partitionFL :: Commute p
  46             => (FORALL(u v) p C(u v) -> Bool)       -- ^predicate; if true we would like the patch in the "left" list
  47             -> FL p C(x y)                          -- ^input 'FL'
  48             -> (FL p :> FL p) C(x y)                -- ^"left" and "right" results
  49
  50 -- optimise by using an accumulating parameter to track all the "right" patches that we've found so far
  51 partitionFL' :: Commute p
  52              => (FORALL(u v) p C(u v) -> Bool)
  53              -> RL p C(x z)  -- the "right" patches found so far
  54              -> FL p C(z y)
  55              -> (FL p :> FL p) C(x y)
  56
  57 partitionFL keepleft ps = partitionFL' keepleft NilRL ps
  58
  59 partitionFL' _ qs NilFL = NilFL :> reverseRL qs
  60 partitionFL' keepleft qs (p :>: ps)
  61    | keepleft p,
  62      Just (p' :> qs') <- commuteRL (qs :> p)
  63        = case partitionFL' keepleft qs' ps of
  64          a :> b -> p' :>: a :> b
  65    | otherwise = partitionFL' keepleft (p :<: qs) ps
  66
  67 -- |split an 'RL' into "left" and "right" lists according to a predicate, using commutation as necessary.
  68 -- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy
  69 -- the predicate, it goes in the "left" list.
  70 partitionRL :: Commute p
  71             => (FORALL(u v) p C(u v) -> Bool)    -- ^predicate; if true we would like the patch in the "right" list
  72             -> RL p C(x y)                       -- ^input 'RL'
  73             -> (RL p :> RL p) C(x y)             -- ^"left" and "right" results
  74
  75 -- optimise by using an accumulating parameter to track all the "left" patches that we've found so far
  76 partitionRL' :: Commute p
  77              => (FORALL(u v) p C(u v) -> Bool)
  78              -> RL p C(x z)
  79              -> FL p C(z y)   -- the "left" patches found so far
  80              -> (RL p :> RL p) C(x y)
  81
  82 partitionRL keepright ps = partitionRL' keepright ps NilFL
  83
  84 partitionRL' _ NilRL qs = reverseFL qs :> NilRL
  85
  86 partitionRL' keepright (p :<: ps) qs
  87    | keepright p,
  88      Right (qs' :> p') <- commuteFL (p :> qs)
  89        = case partitionRL' keepright ps qs' of
  90          a :> b -> a :> p' :<: b
  91    | otherwise = partitionRL' keepright ps (p :>: qs)
  92
  93 commuteWhatWeCanFL :: Commute p => (p :> FL p) C(x y) -> (FL p :> p :> FL p) C(x y)
  94 commuteWhatWeCanFL (p :> x :>: xs) =
  95     case commute (p :> x) of
  96     Nothing -> case commuteWhatWeCanFL (x :> xs) of
  97                xs1 :> x' :> xs2 -> case commuteWhatWeCanFL (p :> xs1) of
  98                               xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2
  99     Just (x' :> p') -> case commuteWhatWeCanFL (p' :> xs) of
 100                        a :> p'' :> c -> x' :>: a :> p'' :> c
 101 commuteWhatWeCanFL (y :> NilFL) = NilFL :> y :> NilFL
 102
 103 commuteWhatWeCanRL :: Commute p => (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y)
 104 commuteWhatWeCanRL = genCommuteWhatWeCanRL commute
 105
 106 genCommuteWhatWeCanRL :: (FORALL(a b) ((p :> p) C(a b) -> Maybe ((p :> p) C(a b))))
 107                       -> (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y)
 108 genCommuteWhatWeCanRL com (x :<: xs :> p) =
 109     case com (x :> p) of
 110     Nothing -> case genCommuteWhatWeCanRL com (xs :> x) of
 111                xs1 :> x' :> xs2 -> case genCommuteWhatWeCanRL com (xs2 :> p) of
 112                               xs1' :> p' :> xs2' -> xs1' +<+ x' :<: xs1 :> p' :> xs2'
 113     Just (p' :> x') -> case genCommuteWhatWeCanRL com (xs :> p') of
 114                        a :> p'' :> c -> a :> p'' :> x' :<: c
 115 genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL
 116
 117
 118 removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) C(x y) -> (FL p :\/: FL p) C(x y)
 119 removeCommon (xs :\/: NilFL) = xs :\/: NilFL
 120 removeCommon (NilFL :\/: xs) = NilFL :\/: xs
 121 removeCommon (xs :\/: ys) = rc xs (headPermutationsFL ys)
 122     where rc :: (MyEq p, Commute p) => FL p C(x y) -> [(p:>FL p) C(x z)] -> (FL p :\/: FL p) C(y z)
 123           rc nms ((n:>ns):_) | Just ms <- removeFL n nms = removeCommon (ms :\/: ns)
 124           rc ms [n:>ns] = ms :\/: n:>:ns
 125           rc ms (_:nss) = rc ms nss
 126           rc _ [] = impossible -- because we already checked for NilFL case
 127
 128 removeFL :: (MyEq p, Commute p) => p C(x y) -> FL p C(x z) -> Maybe (FL p C(y z))
 129 removeFL x xs = r x $ headPermutationsFL xs
 130     where r :: (MyEq p, Commute p) => p C(x y) -> [(p:>FL p) C(x z)] -> Maybe (FL p C(y z))
 131           r _ [] = Nothing
 132           r z ((z':>zs):zss) | IsEq <- z =\/= z' = Just zs
 133                              | otherwise = r z zss
 134
 135 removeRL :: (MyEq p, Commute p) => p C(y z) -> RL p C(x z) -> Maybe (RL p C(x y))
 136 removeRL x xs = r x $ head_permutationsRL xs
 137     where r :: (MyEq p, Commute p) => p C(y z) -> [RL p C(x z)] -> Maybe (RL p C(x y))
 138           r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs
 139                               | otherwise = r z zss
 140           r _ _ = Nothing
 141
 142 remove_subsequenceFL :: (MyEq p, Commute p) => FL p C(a b)
 143                      -> FL p C(a c) -> Maybe (FL p C(b c))
 144 remove_subsequenceFL a b | lengthFL a > lengthFL b = Nothing
 145                          | otherwise = rsFL a b
 146     where rsFL :: (MyEq p, Commute p) => FL p C(a b) -> FL p C(a c) -> Maybe (FL p C(b c))
 147           rsFL NilFL ys = Just ys
 148           rsFL (x:>:xs) yys = removeFL x yys >>= remove_subsequenceFL xs
 149
 150 remove_subsequenceRL :: (MyEq p, Commute p) => RL p C(ab abc)
 151                      -> RL p C(a abc) -> Maybe (RL p C(a ab))
 152 remove_subsequenceRL a b | lengthRL a > lengthRL b = Nothing
 153                          | otherwise = rsRL a b
 154     where rsRL :: (MyEq p, Commute p) => RL p C(ab abc) -> RL p C(a abc) -> Maybe (RL p C(a ab))
 155           rsRL NilRL ys = Just ys
 156           rsRL (x:<:xs) yys = removeRL x yys >>= remove_subsequenceRL xs
 157
 158 head_permutationsFL :: Commute p => FL p C(x y) -> [FL p C(x y)]
 159 head_permutationsFL ps = map (\ (x:>xs) -> x:>:xs) $ headPermutationsFL ps
 160
 161 headPermutationsFL :: Commute p => FL p C(x y) -> [(p :> FL p) C(x y)]
 162 headPermutationsFL NilFL = []
 163 headPermutationsFL (p:>:ps) =
 164     (p:>ps) : catMaybes (map (swapfirstFL.(p:>)) $ headPermutationsFL ps)
 165         where swapfirstFL (p1:>p2:>xs) = do p2':>p1' <- commute (p1:>p2)
 166                                             Just $ p2':>p1':>:xs
 167
 168 head_permutationsRL :: Commute p => RL p C(x y) -> [RL p C(x y)]
 169 head_permutationsRL NilRL = []
 170 head_permutationsRL (p:<:ps) =
 171     (p:<:ps) : catMaybes (map (swapfirstRL.(p:<:)) $ head_permutationsRL ps)
 172         where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1)
 173                                               Just $ p2':<:p1':<:xs
 174               swapfirstRL _ = Nothing
 175
 176 instance (MyEq p, Commute p) => MyEq (FL p) where
 177     a =\/= b | lengthFL a /= lengthFL b = NotEq
 178              | otherwise = cmpSameLength a b
 179              where cmpSameLength :: FL p C(x y) -> FL p C(x z) -> EqCheck C(y z)
 180                    cmpSameLength (x:>:xs) xys | Just ys <- removeFL x xys = cmpSameLength xs ys
 181                    cmpSameLength NilFL NilFL = IsEq
 182                    cmpSameLength _ _ = NotEq
 183     xs =/\= ys = reverseFL xs =/\= reverseFL ys
 184
 185 instance (Invert p, Commute p) => Invert (FL p) where
 186     invert = reverseRL . invertFL
 187     identity = NilFL
 188     sloppyIdentity NilFL = IsEq
 189     sloppyIdentity (x:>:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs
 190     sloppyIdentity _ = NotEq
 191
 192 instance (MyEq p, Commute p) => MyEq (RL p) where
 193     unsafeCompare = bug "Buggy use of unsafeCompare on RL"
 194     a =/\= b | lengthRL a /= lengthRL b = NotEq
 195              | otherwise = cmpSameLength a b
 196              where cmpSameLength :: RL p C(x y) -> RL p C(w y) -> EqCheck C(x w)
 197                    cmpSameLength (x:<:xs) xys | Just ys <- removeRL x xys = cmpSameLength xs ys
 198                    cmpSameLength NilRL NilRL = IsEq
 199                    cmpSameLength _ _ = NotEq
 200     xs =\/= ys = reverseRL xs =\/= reverseRL ys
 201
 202 instance (Commute p, Invert p) => Invert (RL p) where
 203     invert = reverseFL . invertRL
 204     identity = NilRL
 205     sloppyIdentity NilRL = IsEq
 206     sloppyIdentity (x:<:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs
 207     sloppyIdentity _ = NotEq
 208
 209 \end{code}