module Math.Algebra.Group.PermutationGroup where
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import Math.Common.ListSet (toListSet, union, (\\) )
import Math.Core.Utils hiding (elts)
import Math.Algebra.LinearAlgebra hiding (inverse)
infix 8 ~^
rotateL (x:xs) = xs ++ [x]
newtype Permutation a = P (M.Map a a) deriving (Eq,Ord)
p :: (Ord a) => [[a]] -> Permutation a
p = fromCycles
fromPairs xys | isValid = fromPairs' xys
| otherwise = error "Not a permutation"
where (xs,ys) = unzip xys
(xs',ys') = (L.sort xs, L.sort ys)
isValid = xs' == ys' && all ((==1) . length) (L.group xs')
fromPairs' xys = P $ M.fromList $ filter (uncurry (/=)) xys
toPairs (P g) = M.toList g
fromList xs = fromPairs $ zip xs (L.sort xs)
supp (P g) = M.keys g
(.^) :: (Ord a) => a -> Permutation a -> a
x .^ P g = case M.lookup x g of
Just y -> y
Nothing -> x
(-^) :: (Ord a) => [a] -> Permutation a -> [a]
xs -^ g = L.sort [x .^ g | x <- xs]
fromCycles cs = fromPairs $ concatMap fromCycle cs
where fromCycle xs = zip xs (rotateL xs)
toCycles g = toCycles' $ supp g
where toCycles' ys@(y:_) = let c = cycleOf g y in c : toCycles' (ys L.\\ c)
toCycles' [] = []
cycleOf g x = cycleOf' x [] where
cycleOf' y ys = let y' = y .^ g in if y' == x then reverse (y:ys) else cycleOf' y' (y:ys)
instance (Ord a, Show a) => Show (Permutation a) where
show g | g == 1 = "1"
| otherwise = show (toCycles g)
parity g = let cs = toCycles g in (length (concat cs) length cs) `mod` 2
sign g = (1)^(parity g)
orderElt g = foldl lcm 1 $ map length $ toCycles g
instance (Ord a, Show a) => Num (Permutation a) where
g * h = fromPairs' [(x, x .^ g .^ h) | x <- supp g `union` supp h]
fromInteger 1 = P $ M.empty
_ + _ = error "(Permutation a).+: not applicable"
negate _ = error "(Permutation a).negate: not applicable"
abs _ = error "(Permutation a).abs: not applicable"
signum _ = error "(Permutation a).signum: not applicable"
instance (Ord a, Show a) => HasInverses (Permutation a) where
inverse (P g) = P $ M.fromList $ map (\(x,y)->(y,x)) $ M.toList g
(~^) :: (Ord a, Show a) => Permutation a -> Permutation a -> Permutation a
g ~^ h = h^-1 * g * h
comm g h = g^-1 * h^-1 * g * h
closureS xs fs = closure' S.empty (S.fromList xs) where
closure' interior boundary
| S.null boundary = interior
| otherwise =
let interior' = S.union interior boundary
boundary' = S.fromList [f x | x <- S.toList boundary, f <- fs] S.\\ interior'
in closure' interior' boundary'
closure xs fs = S.toList $ closureS xs fs
orbit action x gs = closure [x] [ (`action` g) | g <- gs]
(.^^) :: (Ord a) => a -> [Permutation a] -> [a]
x .^^ gs = orbit (.^) x gs
orbitP gs x = orbit (.^) x gs
orbitV gs x = orbit (.^) x gs
(-^^) :: (Ord a) => [a] -> [Permutation a] -> [[a]]
b -^^ gs = orbit (-^) b gs
orbitB gs b = orbit (-^) b gs
orbitE gs b = orbit (-^) b gs
action xs f = fromPairs [(x, f x) | x <- xs]
orbits gs = let xs = foldl union [] $ map supp gs in orbits' xs
where orbits' [] = []
orbits' (x:xs) = let o = x .^^ gs in o : orbits' (xs L.\\ o)
_C :: (Integral a) => a -> [Permutation a]
_C n | n >= 2 = [p [[1..n]]]
_D n | r == 0 = _D2 q where (q,r) = n `quotRem` 2
_D2 n | n >= 3 = [a,b] where
a = p [[1..n]]
b = p [[i,n+1i] | i <- [1..n `div` 2]]
_S :: (Integral a) => a -> [Permutation a]
_S n | n >= 3 = [s,t]
| n == 2 = [t]
| n == 1 = []
where s = p [[1..n]]
t = p [[1,2]]
_A :: (Integral a) => a -> [Permutation a]
_A n | n > 3 = [s,t]
| n == 3 = [t]
| n == 2 = []
where s | odd n = p [[3..n]]
| even n = p [[1,2], [3..n]]
t = p [[1,2,3]]
dp :: (Ord a, Ord b) => [Permutation a] -> [Permutation b] -> [Permutation (Either a b)]
dp hs ks =
[P $ M.fromList $ map (\(x,x') -> (Left x,Left x')) $ M.toList h' | P h' <- hs] ++
[P $ M.fromList $ map (\(y,y') -> (Right y,Right y')) $ M.toList k' | P k' <- ks]
wr hs ks =
let _X = S.toList $ foldl S.union S.empty [M.keysSet h' | P h' <- hs]
_Y = S.toList $ foldl S.union S.empty [M.keysSet k' | P k' <- ks]
_B = [P $ M.fromList $ map (\(x,x') -> ((x,y),(x',y))) $ M.toList h' | P h' <- hs, y <- _Y]
_T = [P $ M.fromList [((x,y),(x,y')) | x <- _X, (y,y') <- M.toList k'] | P k' <- ks]
in _B ++ _T
toSn gs = [toSn' g | g <- gs] where
_X = L.sort $ foldl union [] $ map supp gs
mapping = M.fromList $ zip _X [1..]
toSn' g = fromPairs' $ map (\(x,x') -> (mapping M.! x, mapping M.! x')) $ toPairs g
fromDigits g = fromPairs [(fromDigits' x, fromDigits' y) | (x,y) <- toPairs g]
fromDigits' xs = f (reverse xs) where
f (x:xs) = x + 10 * f xs
f [] = 0
fromBinary g = fromPairs [(fromBinary' x, fromBinary' y) | (x,y) <- toPairs g]
fromBinary' xs = f (reverse xs) where
f (x:xs) = x + 2 * f xs
f [] = 0
elts :: (Num a, Ord a) => [a] -> [a]
elts gs = closure [1] [ (*g) | g <- gs]
eltsS gs = closureS [1] [ (*g) | g <- gs]
order :: (Num a, Ord a) => [a] -> Int
order gs = S.size $ eltsS gs
isMember gs h = h `S.member` eltsS gs
minsupp = head . supp
orderTGS tgs =
let transversals = map (1:) $ L.groupBy (\g h -> minsupp g == minsupp h) tgs
in product $ map L.genericLength transversals
eltsTGS tgs =
let transversals = map (1:) $ L.groupBy (\g h -> minsupp g == minsupp h) tgs
in map product $ sequence transversals
tgsFromSgs sgs = concatMap transversal bs where
bs = toListSet $ map minsupp sgs
transversal b = closure b $ filter ( (b <=) . minsupp ) sgs
closure b gs = closure' M.empty (M.fromList [(b, 1)]) where
closure' interior boundary
| M.null boundary = filter (/=1) $ M.elems interior
| otherwise =
let interior' = M.union interior boundary
boundary' = M.fromList [(x .^ g, h*g) | (x,h) <- M.toList boundary, g <- gs] M.\\ interior'
in closure' interior' boundary'
orderSGS :: (Ord a) => [Permutation a] -> Integer
orderSGS sgs = product $ map (L.genericLength . fundamentalOrbit) bs where
bs = toListSet $ map minsupp sgs
fundamentalOrbit b = b .^^ filter ( (b <=) . minsupp ) sgs
gens hs = gens' [] (S.singleton 1) hs where
gens' gs eltsG (h:hs) = if h `S.member` eltsG then gens' gs eltsG hs else gens' (h:gs) (eltsS $ h:gs) hs
gens' gs _ [] = reverse gs
h ~^^ gs = conjClass gs h
conjClass gs h = closure [h] [ (~^ g) | g <- gs]
conjClassReps :: (Ord a, Show a) => [Permutation a] -> [(Permutation a, Int)]
conjClassReps gs = conjClassReps' (elts gs) where
conjClassReps' (h:hs) =
let cc = conjClass gs h in (h, length cc) : conjClassReps' (hs \\ cc)
conjClassReps' [] = []
reduceGens (1:gs) = reduceGens gs
reduceGens (g:gs) = reduceGens' ([g], eltsS [g]) gs where
reduceGens' (gs,eltsgs) (h:hs) =
if h `S.member` eltsgs
then reduceGens' (gs,eltsgs) hs
else reduceGens' (h:gs, eltsS $ h:gs) hs
reduceGens' (gs,_) [] = reverse gs
isSubgp hs gs = all (`S.member` gs') hs
where gs' = eltsS gs
subgps :: (Ord a, Show a) => [Permutation a] -> [[Permutation a]]
subgps gs = [] : subgps' S.empty [] (map (:[]) hs) where
hs = filter isMinimal $ elts gs
subgps' found ls (r:rs) =
let ks = elts r in
if ks `S.member` found
then subgps' found ls rs
else r : subgps' (S.insert ks found) (r:ls) rs
subgps' found [] [] = []
subgps' found ls [] = subgps' found [] [l ++ [h] | l <- reverse ls, h <- hs, last l < h]
isMinimal 1 = False
isMinimal g = all (g <=) primitives
where powers = takeWhile (/=1) $ tail $ iterate (*g) 1
n = orderElt g
primitives = filter (\h -> orderElt h == n) powers
centralizer gs hs = [k | k <- elts gs, all (\h -> h*k == k*h) hs]
centre gs = centralizer gs gs
normalizer gs hs = [g | g <- elts gs, all (\h -> h~^g `elem` elts hs) hs]
stabilizer gs x = [g | g <- elts gs, x .^ g == x]
ptStab gs xs = [g | g <- elts gs, and [x .^ g == x | x <- xs] ]
setStab gs xs = [g | g <- elts gs, xs -^ g == xs]
normalClosure gs hs = reduceGens $ hs ++ [h ~^ g | h <- hs, g <- gs ++ map inverse gs]
commutatorGp hs ks = normalClosure (hsks) [h^-1 * k^-1 * h * k | h <- hs', k <- ks']
where hs' = reduceGens hs
ks' = reduceGens ks
hsks = reduceGens (hs' ++ ks')
derivedSubgp gs = commutatorGp gs gs
xs -*- ys = toListSet [x*y | x <- xs, y <- ys]
xs -* y = L.sort [x*y | x <- xs]
x *- ys = L.sort [x*y | y <- ys]
isNormal :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> Bool
isNormal gs ks = all (== ks') [ (g^-1) *- ks' -* g | g <- gs]
where ks' = elts ks
normalSubgps :: (Ord a, Show a) => [Permutation a] -> [[Permutation a]]
normalSubgps gs = filter (isNormal gs) (subgps gs)
isSimple gs = length (normalSubgps gs) == 2
cosets gs hs = orbit (-*) hs' gs
where hs' = elts hs
quotientGp :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> [Permutation Int]
quotientGp gs ks
| ks `isNormal` gs = gens $ toSn [action cosetsK (-* g) | g <- gs]
| otherwise = error "quotientGp: not well defined unless ks normal in gs"
where cosetsK = cosets gs ks
(//) :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> [Permutation Int]
gs // ks = quotientGp gs ks
xs ~~^ g = L.sort [x ~^ g | x <- xs]
conjugateSubgps gs hs = orbit (~~^) hs' gs
where hs' = elts hs
subgpAction gs hs =
let conjugatesH = conjugateSubgps gs hs
in toSn [action conjugatesH (~~^ g) | g <- gs]
rrpr gs h = rrpr' (elts gs) h
rrpr' gs h = fromPairs [(g, g*h) | g <- gs]
permutationMatrix xs g = [ [if x .^ g == y then 1 else 0 | y <- xs] | x <- xs ]