never executed always true always false
1 -- | Safely handle permutations with permutation-safe.
2 -- Conversion between standard permutation forms.
3 -- Helpful errors are given when trying to construct permutations with invalid data.
4 module Conjure.Util.Permutation
5 ( -- * The Permutation Type
6 Permutation (),
7
8 -- ** Error Type
9 PermutationError (..),
10
11 -- ** Smart Constructors
12 fromCycles,
13 fromRelation,
14 fromTwoLineForm,
15
16 -- ** Accessors
17 toFunction,
18 toCycles,
19 toCyclesCanonical,
20 toRelation,
21 toTwoLineForm,
22 permutedPoints,
23
24 -- * Permutation Utilities
25 inverse,
26 size,
27 (^^^),
28 completedCycles,
29 )
30 where
31
32 import Conjure.Prelude
33 import Control.Monad.State.Strict (State, put)
34 import Data.Semigroup ((<>))
35
36 --------------------------Safe Permutation Type----------------------------------------
37
38 -- | The Permutation constructor is for internal use only.
39 -- To construct a permutation use any of the smart constructors.
40 newtype Permutation a = Permutation [(a, a)] deriving (Show)
41
42 -- | Equality tests that permutations contain the same permuted values.
43 instance (Eq a) => Eq (Permutation a) where
44 (==) (Permutation l) (Permutation r) = and [e `elem` r | e <- l]
45
46 -- | Permutations compose as a semigroup in the same way they would compose if you composed them as functions.
47 instance (Eq a) => Semigroup (Permutation a) where
48 (<>) pl@(Permutation l) pr@(Permutation r) =
49 let flatten z = (z >>= (\(x, y) -> [x, y]))
50 elemsofp = nub $ flatten l ++ flatten r
51 permfunc = toFunction pl . toFunction pr
52 in case fromRelation (zip elemsofp (permfunc <$> elemsofp)) of
53 Left _ ->
54 error
55 $ "Data.Permutation.Semigroup: this should only happen "
56 ++ "if you didn't use a smart constructor AND created a "
57 ++ "Permutation object that is not in fact a permutation.\n"
58 ++ "If you did use a smart constructor and you see this "
59 ++ "error then please submit a bug report with a minimal "
60 ++ "failing example."
61 Right p -> p
62
63 -- | The Monoid identity is the identity permutation. The Monoid plus is semigroup composition.
64 instance (Eq a) => Monoid (Permutation a) where
65 mempty = Permutation []
66 mappend = (<>)
67
68 --------------------------Error Type--------------------------------------------------
69
70 -- | There may be an error detailing why the permutation computation has failed.
71 newtype PermutationError = PermutationError String
72 deriving (Eq, Show)
73
74 -- | Create a Permutation from disjoint cycles.
75 fromCycles :: (Eq a) => [[a]] -> Either PermutationError (Permutation a)
76 fromCycles c =
77 if length (join c) /= length (nub $ join c)
78 then
79 Left
80 $ PermutationError
81 "Data.Permutation.fromCycles: Cycles contain a duplicate element"
82 else Right $ Permutation $ c >>= cycleToTuples
83 where
84 cycleToTuples :: [a] -> [(a, a)]
85 cycleToTuples [] = []
86 cycleToTuples [_] = []
87 cycleToTuples l@(lHead : lTail) = zip (cycle l) (lTail ++ [lHead])
88
89 -- | Create a permutation from a relation a*a.
90 -- Only non identity mappings need be specified
91 -- (e.g. fromRelation [(1,2),(2,1),(3,3)] == fromRelation [(1,2),(2,1)]).
92 fromRelation :: (Eq a) => [(a, a)] -> Either PermutationError (Permutation a)
93 fromRelation r =
94 let perm = Permutation $ filter (uncurry (/=)) r
95 in if isBijective $ Permutation r
96 then Right perm
97 else
98 Left
99 $ PermutationError
100 "Data.Permutation.fromRelation: The relation is not bijective"
101
102 -- | Create a permutation from two line form.
103 --
104 -- > fromTwoLineForm ([2,4,7,3]
105 -- > ,[7,3,2,4])
106 fromTwoLineForm :: (Eq a) => ([a], [a]) -> Either PermutationError (Permutation a)
107 fromTwoLineForm (t, b) =
108 if length t /= length b
109 then
110 Left
111 $ PermutationError
112 "Data.Permutation.fromTwoLineForm: The top and bottom lines have different length"
113 else fromRelation (zip t b)
114
115 --------------------------Permutation Utilities----------------------------------------
116
117 -- | Gets the permutation as a function.
118 toFunction :: (Eq a) => Permutation a -> (a -> a)
119 toFunction (Permutation p) v = fromMaybe v (lookup v p)
120
121 -- | Convert the permutation to cycle form.
122 toCycles :: (Eq a) => Permutation a -> [[a]]
123 toCycles (Permutation p) = evalState go ([], [], p)
124 where
125 go :: (Eq a) => CycleFinder a [[a]]
126 go = do
127 cf <- cyclesFound
128 if cf
129 then returnCycles
130 else do
131 wc <- workingCycle
132 case wc of
133 [] -> startNewCycle >> go
134 _ -> nextCycleElem >> go
135
136 -- | Convert the permutation to canonical cycle form.
137 toCyclesCanonical :: (Eq a, Ord a) => Permutation a -> [[a]]
138 toCyclesCanonical (Permutation p) =
139 toCycles (Permutation $ sortBy (\x y -> fst x `compare` fst y) p)
140
141 -- | Given a lower and upper bound on a and a permutation within this range
142 -- returns a two line for representation.
143 toRelation ::
144 (Eq a, Enum a) =>
145 -- | Lower bound
146 a ->
147 -- | Upper bound
148 a ->
149 Permutation a ->
150 Either PermutationError [(a, a)]
151 toRelation from to p@(Permutation pe) =
152 let maybep = zip [from .. to] (toFunction p <$> [from .. to])
153 in if length [from .. to] == length ([from .. to] \\ (fst <$> pe)) + length pe
154 then Right maybep
155 else
156 Left
157 $ PermutationError
158 "Data.Permutation.toRelation: the range used does not cover the permuted elements"
159
160 -- | Given a lower and upper bound on a and a permutation within this range
161 -- returns a two line for representation.
162 toTwoLineForm ::
163 (Eq a, Enum a) =>
164 -- | Lower bound
165 a ->
166 -- | Upper bound
167 a ->
168 Permutation a ->
169 Either PermutationError ([a], [a])
170 toTwoLineForm from to p =
171 case toRelation from to p of
172 Left _ ->
173 Left
174 $ PermutationError
175 "Data.Permutation.toTwoLineForm: the range used does not cover the permuted elements"
176 Right rf -> Right $ unzip rf
177
178 -- | Gets the list of points that are acted on by the permutation.
179 permutedPoints :: Permutation a -> [a]
180 permutedPoints (Permutation p) = fst <$> p
181
182 -- | Power of a permutation.
183 (^^^) :: (Eq a) => Permutation a -> Int -> Permutation a
184 (^^^) _ 0 = Permutation []
185 (^^^) p 1 = p
186 (^^^) p n = p <> (p ^^^ (n - 1))
187
188 -- | Gets the size of the permutation. The number of elements not mapped to themselves.
189 size :: Permutation a -> Int
190 size (Permutation p) = length p
191
192 -- | Gets the inverse of the permutation.
193 inverse :: Permutation a -> Permutation a
194 inverse (Permutation p) = Permutation $ (\(x, y) -> (y, x)) <$> p
195
196 --------------------------Bijectivity Checking-----------------------------------------
197
198 -- | Equality is required to assess inner relation bijectivity.
199 isBijective :: (Eq a) => Permutation a -> Bool
200 isBijective (Permutation p) =
201 let (l, r) = unzip p
202 in (length (nub l) == length (nub r))
203 && (length (nub l) == length l)
204 && null (l \\ r)
205
206 -------------------------CycleFinder Monad---------------------------------------------
207
208 -- | A builder monad for finding cycles.
209 type CycleFinder a = State ([a], [[a]], [(a, a)])
210
211 -- | The current cycle we are working on.
212 workingCycle :: CycleFinder a [a]
213 workingCycle = do
214 (w, _, _) <- get
215 return w
216
217 -- | Gets the completed cycles.
218 completedCycles :: CycleFinder a [[a]]
219 completedCycles = do
220 (_, c, _) <- get
221 return c
222
223 -- | Finds the element that a maps on to.
224 mapsOnto :: (Eq a) => a -> CycleFinder a a
225 mapsOnto i = do
226 (_, _, m) <- get
227 case lookup i m of
228 Nothing ->
229 error
230 $ "Data.Permutation.toCycles: this should only happen "
231 ++ "if you didn't use a smart constructor AND created a "
232 ++ "Permutation object that is not in fact a permutation.\n"
233 ++ "If you did use a smart constructor and you see this "
234 ++ "error then please submit a bug report with a minimal "
235 ++ "failing example."
236 Just so -> return so
237
238 -- | The exit condition - whether we have found all the cycles.
239 cyclesFound :: (Eq a) => CycleFinder a Bool
240 cyclesFound = do
241 (w, _, m) <- get
242 return (null w && null m)
243
244 -- | Returns the cycles.
245 returnCycles :: CycleFinder a [[a]]
246 returnCycles = do
247 (_, c, _) <- get
248 return $ reverse c
249
250 -- | Start finding a new cycle.
251 startNewCycle :: CycleFinder a ()
252 startNewCycle = do
253 got <- get
254 case got of
255 (_, c, (a, b) : m) -> put ([a, b], c, m)
256 _ -> error "Data.Permutation.Internal.startNewCycle: this should never happen"
257
258 -- | Adds the next element of the cycle.
259 nextCycleElem :: (Eq a) => CycleFinder a ()
260 nextCycleElem = do
261 (w, c, m) <- get
262 let w_last = last w
263 next <- mapsOnto w_last
264 let filt = filter (/= (w_last, next)) m
265 if take 1 w == [next]
266 then put ([], w : c, filt)
267 else put (w ++ [next], c, filt)