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)
rotateL (x:xs) = xs ++ [x]
newtype Permutation a = P (M.Map a a) deriving (Eq,Ord)
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
x .^ P g = case M.lookup x g of
Just y -> y
Nothing -> x
fromCycles cs = fromPairs $ concatMap fromCycle cs
where fromCycle xs = zip xs (rotateL xs)
p cs = fromCycles cs
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 = 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
inverse (P g) = P $ M.fromList $ map (\(x,y)->(y,x)) $ M.toList g
g ^- n = inverse g ^ n
instance (Ord a, Show a) => Fractional (Permutation a) where
recip = inverse
h ~^ g = g^-1 * h * g
comm g h = g^-1 * h^-1 * g * h
xs -^ g = L.sort [x .^ g | x <- xs]
orbit action x gs = S.toList $ orbitS action x gs
orbitS action x gs = orbit' S.empty (S.singleton x) where
orbit' interior boundary
| S.null boundary = interior
| otherwise =
let interior' = S.union interior boundary
boundary' = S.fromList [p `action` g | g <- gs, p <- S.toList boundary] S.\\ interior'
in orbit' interior' boundary'
x .^^ gs = orbit (.^) x gs
orbitP gs x = orbit (.^) x gs
b -^^ gs = orbit (-^) b gs
orbitB gs b = orbit (-^) b gs
inducedAction bs g = fromPairs [(b, b -^ g) | b <- bs]
induced action bs g = fromPairs [(b, b `action` g) | b <- bs]
inducedB bs g = induced (-^) bs g
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 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 = fromPairs $ [(i,n+1i) | i <- [1..n]]
_S n | n >= 3 = [s,t] where
s = p [[1..n]]
t = p [[1,2]]
_A n | n == 3 = [t]
| n > 3 = [s,t] where
s | odd n = p [[3..n]]
| even n = p [[1,2], [3..n]]
t = p [[1,2,3]]
cp 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 = 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
elts gs = orbit (*) 1 gs
eltsS gs = orbitS (*) 1 gs
order gs = S.size $ eltsS gs
isMember gs h = h `S.member` eltsS gs
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 = orbit (~^) h gs
conjClass gs h = h ~^^ gs
conjClasses gs = conjClasses' (elts gs)
where conjClasses' [] = []
conjClasses' (h:hs) = let c = conjClass gs h in c : conjClasses' (hs L.\\ c)
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]
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
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
isSubgp hs gs = all (isMember gs) hs
isNormal hs gs = isSubgp hs gs && all (isMember hs) [h~^g | h <- hs, g <- gs]
hs **^ g = L.sort [h*g | h <- hs]
cosets gs hs = orbit (**^) hs gs
cosetAction gs hs =
let _H = elts hs
cosets_H = cosets gs _H
in toSn $ map (induced (**^) cosets_H) gs
quotientGp gs hs
| hs `isNormal` gs = gens $ cosetAction gs hs
| otherwise = error "quotientGp: not well defined unless H normal in G"
gs // hs = quotientGp gs hs
hs ~~^ g = L.sort [h ~^ g | h <- hs]
conjugateSubgps gs hs = orbit (~~^) hs gs
subgpAction gs hs =
let _H = elts hs
conjugates_H = conjugateSubgps gs _H
in toSn $ map (induced (~~^) conjugates_H) gs