HaskellForMaths-0.2.0: Math/Algebra/Group/SchreierSims.hs
-- Copyright (c) David Amos, 2008. All rights reserved.
module Math.Algebra.Group.SchreierSims where
import qualified Data.List as L
import Data.Maybe (isNothing, isJust)
import qualified Data.Set as S
import qualified Data.Map as M
import Math.Algebra.Group.PermutationGroup hiding (elts, order, gens, isMember, isSubgp, isNormal, reduceGens, normalClosure, commutatorGp, derivedSubgp)
import Math.Common.ListSet (toListSet)
-- COSET REPRESENTATIVES FOR STABILISER OF A POINT
-- Given a group G = <gs>, and a point x, find coset representatives for Gx (stabiliser of x) in G
-- In other words, for each x' in the orbit of x under G, we find a g <- G taking x to x'
-- The code is similar to the code for calculating orbits, but modified to keep track of the group elements that we used to get there
cosetRepsGx gs x = cosetRepsGx' gs M.empty (M.singleton x 1) where
cosetRepsGx' gs interior boundary
| M.null boundary = interior
| otherwise =
let interior' = M.union interior boundary
boundary' = M.fromList [(p .^ g, h*g) | g <- gs, (p,h) <- M.toList boundary] M.\\ interior'
in cosetRepsGx' gs interior' boundary'
-- SCHREIER GENERATORS
-- toSet xs = (map head . group . sort) xs
-- Generators for Gx, the stabiliser of x, given that G is generated by gs, and rs is a set of coset representatives for Gx in G.
-- Schreier's Lemma states that if H < G = <S>, and R is a set of coset reps for H in G
-- then H is generated by { rs(rs)*^-1 | r <- R, s <- S } (where * means "the coset representative of")
-- In particular, with H = Gx, this gives us a way of finding a set of generators for Gx
schreierGeneratorsGx (x,rs) gs = L.nub $ filter (/= 1) [schreierGenerator r g | r <- M.elems rs, g <- gs]
where schreierGenerator r g = let h = r * g
h' = rs M.! (x .^ h)
in h * inverse h'
-- SCHREIER-SIMS ALGORITHM
sift bts g = sift' bts g where
sift' _ 1 = Nothing
sift' ((b,t):bts) g = case M.lookup (b .^ g) t of
Nothing -> Just g
-- Nothing -> sift' bts g -- if we allow empty levels
Just h -> sift' bts (g * inverse h)
sift' [] g = if g == 1 then Nothing else Just g
findBase gs = minimum $ concatMap supp gs
{-
-- Find base and strong generating set using Schreier-Sims algorithm
bsgs gs | all (/= 1) gs = map fst $ ss [newLevel gs] []
newLevel s = let b = findBase s
t = cosetRepsGx s b
in ((b,t),s)
ss (bad@((b,t),s):bads) goods =
let bts = map fst goods
sgs = schreierGeneratorsGx (b,t) s
siftees = filter isJust $ map (sift bts) sgs
in if null siftees
then ss bads (bad:goods)
else let Just h = head siftees
in if null goods
then ss (newLevel [h] : bad : bads) []
else let ((b_,t_),s_) = head goods
s' = h:s_
t' = cosetRepsGx s' b_
in ss (((b_,t'),s') : bad : bads) (tail goods)
ss [] goods = goods
-}
-- |Given generators for a permutation group, return a strong generating set.
-- The result is calculated using Schreier-Sims algorithm, and is relative to the base implied by the Ord instance
sgs :: (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs gs = toListSet $ concatMap snd $ ss bs gs
where bs = toListSet $ concatMap supp gs
-- Find base and strong generating set using Schreier-Sims algorithm
-- !! This function is poorly named - it actually finds you a base and sets of transversals
-- This version guarantees to use bases in order
bsgs gs = bsgs' bs gs
where bs = toListSet $ concatMap supp gs
-- This version lets you pass in bases in the order you want them (or [], and it will find its own)
bsgs' bs gs = map fst $ ss bs gs
-- For example, bsgs (_A 5) uses [1,2,3] as the bases, but bsgs' [] (_A 5) uses [1,3,2]
newLevel (b:bs) s = (bs, newLevel' b s)
newLevel [] s = ([], newLevel' b s) where b = findBase s
newLevel' b s = ((b,t),s) where t = cosetRepsGx s b
ss bs gs = ss' bs' [level] []
where (bs',level) = newLevel bs $ filter (/=1) gs
ss' bs (bad@((b,t),s):bads) goods =
let bts = map fst goods
sgs = schreierGeneratorsGx (b,t) s
siftees = filter isJust $ map (sift bts) sgs
in if null siftees
then ss' bs bads (bad:goods)
else let Just h = head siftees
in if null goods
then let (bs', level) = newLevel bs [h]
in ss' bs' (level : bad : bads) []
else let ((b_,t_),s_) = head goods
s' = h:s_
t' = cosetRepsGx s' b_
in ss' bs (((b_,t'),s') : bad : bads) (tail goods)
ss' _ [] goods = goods
{-
extendbsgs [] g = bsgs [g]
extendbsgs (((b,t),s):bts) g = ss (((b,t),g:s):bts) []
bsgs' gs = map fst $ foldl extendbsgs [] gs
-}
-- The above is written for simplicity.
-- Its efficiency could be improved by incrementally updating the transversals,
-- and keeping track of Schreier generators we have already tried.
-- (Remember to add new Schreier generators every time the generating set or transversal is augmented.)
-- USING THE SCHREIER-SIMS TRANSVERSALS
isMemberBSGS bts g = isNothing $ sift bts g
-- By Lagrange's thm, every g <- G can be written uniquely as g = r_m ... r_1 (Seress p56)
-- Note that we have to reverse the list of coset representatives
eltsBSGS bts = map (product . reverse) (cartProd ts)
where ts = map (M.elems . snd) bts
cartProd (set:sets) = [x:xs | x <- set, xs <- cartProd sets]
cartProd [] = [[]]
orderBSGS bts = product (map (toInteger . M.size . snd) bts)
-- |Given generators for a group, determine whether a permutation is a member of the group, using Schreier-Sims algorithm
isMember :: (Ord t, Show t) => [Permutation t] -> Permutation t -> Bool
isMember gs h = isMemberBSGS (bsgs gs) h
-- |Given generators for a group, return a (sorted) list of all elements of the group, using Schreier-Sims algorithm
elts :: (Ord t, Show t) => [Permutation t] -> [Permutation t]
elts [] = [1]
elts gs = eltsBSGS $ bsgs gs
-- |Given generators for a group, return the order of the group (the number of elements), using Schreier-Sims algorithm
order :: (Ord t, Show t) => [Permutation t] -> Integer
order [] = 1
order gs = orderBSGS $ bsgs gs
isSubgp hs gs = all (isMemberBSGS gs') hs
where gs' = bsgs gs
isNormal hs gs = hs `isSubgp` gs
&& all (isMemberBSGS hs') [h~^g | h <- hs, g <- gs]
where hs' = bsgs hs
index gs hs = order gs `div` order hs
-- given list of generators, try to find a shorter list
reduceGens gs = fst $ reduceGensBSGS (filter (/=1) gs)
reduceGensBSGS (g:gs) = reduceGens' ([g],bsgs [g]) gs where
reduceGens' (gs,bsgsgs) (h:hs) =
if isMemberBSGS bsgsgs h
then reduceGens' (gs,bsgsgs) hs
else reduceGens' (h:gs, bsgs $ h:gs) hs
reduceGens' (gs,bsgsgs) [] = (reverse gs,bsgsgs)
reduceGensBSGS [] = ([],[])
-- normal closure of H in G
-- for efficiency, should be called with gs and hs already reduced sets of generators
normalClosure gs hs = reduceGens $ hs ++ [h ~^ g | h <- hs, g <- gs']
where gs' = gs ++ map inverse gs
-- commutator gp of H and K
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')
-- no point processing more potential generators than we have to
-- derived subgroup (or commutator subgroup)
derivedSubgp gs = normalClosure gs' [g^-1 * h^-1 * g * h | g <- gs', h <- gs']
where gs' = reduceGens gs
-- == commutatorGp gs gs
{-
isPerfect gs = order gs == order (derivedSubgp gs)
-- We compare orders rather than the generators themselves, because derivedSubgp will usually find different generators
derivedSeries gs = derivedSeries' (gs, order gs) where
derivedSeries' ([],1) = [[]]
derivedSeries' (hs, orderhs) =
let hs' = derivedSubgp hs
orderhs' = order hs'
in if orderhs' == orderhs
then [hs]
else hs : derivedSeries' (hs',orderhs')
lowerCentralSeries gs = lowerCentralSeries' (gs, order gs) where
lowerCentralSeries' ([],1) = [[]]
lowerCentralSeries' (hs, orderhs) =
let hs' = commutatorGp gs hs
orderhs' = order hs'
in if orderhs' == orderhs
then [hs]
else hs : lowerCentralSeries' (hs',orderhs')
-}