module Math.Algebra.Group.Subquotients where
import qualified Data.List as L
import qualified Data.Map as M
import Math.Common.ListSet
import Math.Algebra.Group.PermutationGroup hiding (ptStab, normalClosure)
import Math.Algebra.Group.SchreierSims (cosetRepsGx)
import Math.Algebra.Group.RandomSchreierSims
isLeft (Left _) = True
isLeft (Right _) = False
isRight (Right _) = True
isRight (Left _) = False
unRight = fromPairs . map (\(Right a, Right b) -> (a,b)) . toPairs
restrictLeft g = fromPairs [(a,b) | (Left a, Left b) <- toPairs g]
ptStab gs delta = map unRight $ dropWhile (isLeft . minsupp) $ sgs gs' where
gs' = [ (fromPairs . map (\(a,b) -> (lr a, lr b)) . toPairs) g | g <- gs]
lr x = if x `elem` delta then Left x else Right x
isTransitive gs = length (orbits gs) == 1
transitiveConstituentHomomorphism gs delta
| delta == closure delta [(.^ g) | g <- gs]
= transitiveConstituentHomomorphism' gs delta
transitiveConstituentHomomorphism' gs delta = (ker, im) where
gs' = sgs $ map (fromPairs . map (\(a,b) -> (lr a, lr b)) . toPairs) gs
lr x = if x `elem` delta then Left x else Right x
ker = map unRight $ dropWhile (isLeft . minsupp) gs'
im = map restrictLeft $ takeWhile (isLeft . minsupp) gs'
minimalBlock gs ys@(y1:yt) = minimalBlock' p yt gs where
xs = foldl union [] $ map supp gs
p = M.fromList $ [(yi,y1) | yi <- ys] ++ [(x,x) | x <- xs \\ ys]
minimalBlock' p (q:qs) (h:hs) =
let r = p M.! q
k = p M.! (q .^ h)
l = p M.! (r .^ h)
in if k /= l
then let p' = M.map (\x -> if x == l then k else x) p
qs' = qs ++ [l]
in minimalBlock' p' (q:qs') hs
else minimalBlock' p (q:qs) hs
minimalBlock' p (q:qs) [] = minimalBlock' p qs gs
minimalBlock' p [] _ =
let reps = toListSet $ M.elems p
in L.sort [ filter (\x -> p M.! x == r) xs | r <- reps ]
blockSystems gs
| isTransitive gs = toListSet $ filter (/= [x:xs]) $ map (minimalBlock gs) [ [x,x'] | x' <- xs ]
| otherwise = error "blockSystems: not transitive"
where x:xs = foldl union [] $ map supp gs
blockSystemsSGS gs = toListSet $ filter (/= [x:xs]) $ map (minimalBlock gs) [ [x,x'] | x' <- rs ]
where x:xs = foldl union [] $ map supp gs
hs = filter (\g -> x < minsupp g) gs
os = orbits hs
rs = map head os ++ (xs \\ L.sort (concat os))
isPrimitive gs = null (blockSystems gs)
isPrimitiveSGS gs = null (blockSystemsSGS gs)
blockHomomorphism gs bs
| bs == closure bs [(-^ g) | g <- gs]
= blockHomomorphism' gs bs
blockHomomorphism' gs bs = (ker,im) where
gs' = sgs $ map lr gs
lr g = fromPairs $ [(Left b, Left $ b -^ g) | b <- bs] ++ [(Right x, Right y) | (x,y) <- toPairs g]
ker = map unRight $ dropWhile (isLeft . minsupp) gs'
im = map restrictLeft $ takeWhile (isLeft . minsupp) gs'
normalClosure gs hs = map unRight $ dropWhile (isLeft . minsupp) $ sgs ks where
xs = foldl union [] $ map supp $ gs ++ hs
ds = map diag gs
diag g = fromPairs $ concat [ [(Left x, Left y) , (Right x, Right y)] | (x,y) <- toPairs g]
hsR = map inR hs
inR h = fromPairs [(Right x, Right y) | (x,y) <- toPairs h]
ks = ds ++ hsR
intersectionNormalClosure gs hs = map unRight $ dropWhile (isLeft . minsupp) $ sgs ks where
xs = foldl union [] $ map supp $ gs ++ hs
ds = map diag gs
diag g = fromPairs $ concat [ [(Left x, Left y) , (Right x, Right y)] | (x,y) <- toPairs g]
hsL = map inL hs
inL h = fromPairs [(Left x, Left y) | (x,y) <- toPairs h]
ks = ds ++ hsL
centralizerSymTrans gs = filter (/= 1) $ centralizerSymTrans' [] fix_g_a where
xs@(a:_) = foldl union [] $ map supp gs
ss = sgs gs
g_a = dropWhile ( (==a) . minsupp ) ss
fix_g_a = xs \\ (foldl union [] $ map supp g_a)
reps_a = cosetRepsGx gs a
centralizingElt b = fromPairs [ let g = reps_a M.! x in (x, b .^ g) | x <- xs ]
centralizerSymTrans' ls (r:rs) =
let c = centralizingElt r
in c : centralizerSymTrans' (c:ls) (rs \\ orbitP (c:ls) a)
centralizerSymTrans' _ [] = []