-- Copyright (c) David Amos, 2009. All rights reserved.

{-# LANGUAGE NoMonomorphismRestriction #-}
-- Because unRight defined point-free

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


-- Source: Seress, Permutation Group Algorithms


isLeft :: Either a b -> Bool
isLeft (Left _) = Bool
True
isLeft (Right _) = Bool
False

isRight :: Either a b -> Bool
isRight (Right _) = Bool
True
isRight (Left _) = Bool
False


unRight :: Permutation (Either a a) -> Permutation a
unRight = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a)
-> (Permutation (Either a a) -> [(a, a)])
-> Permutation (Either a a)
-> Permutation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Either a a, Either a a) -> (a, a))
-> [(Either a a, Either a a)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Right a :: a
a, Right b :: a
b) -> (a
a,a
b)) ([(Either a a, Either a a)] -> [(a, a)])
-> (Permutation (Either a a) -> [(Either a a, Either a a)])
-> Permutation (Either a a)
-> [(a, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation (Either a a) -> [(Either a a, Either a a)]
forall a. Permutation a -> [(a, a)]
toPairs

restrictLeft :: Permutation (Either a b) -> Permutation a
restrictLeft g :: Permutation (Either a b)
g = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [(a
a,a
b) | (Left a :: a
a, Left b :: a
b) <- Permutation (Either a b) -> [(Either a b, Either a b)]
forall a. Permutation a -> [(a, a)]
toPairs Permutation (Either a b)
g]
-- note that this is doing a filter - taking only the left part of the action - and a map, unLefting


-- pointwise stabiliser of xs
ptStab :: [Permutation a] -> t a -> [Permutation a]
ptStab gs :: [Permutation a]
gs delta :: t a
delta = (Permutation (Either a a) -> Permutation a)
-> [Permutation (Either a a)] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map Permutation (Either a a) -> Permutation a
forall a a. Ord a => Permutation (Either a a) -> Permutation a
unRight ([Permutation (Either a a)] -> [Permutation a])
-> [Permutation (Either a a)] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (Permutation (Either a a) -> Bool)
-> [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Either a a -> Bool
forall a b. Either a b -> Bool
isLeft (Either a a -> Bool)
-> (Permutation (Either a a) -> Either a a)
-> Permutation (Either a a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation (Either a a) -> Either a a
forall c. Permutation c -> c
minsupp) ([Permutation (Either a a)] -> [Permutation (Either a a)])
-> [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a b. (a -> b) -> a -> b
$ [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a. (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs [Permutation (Either a a)]
gs' where
    gs' :: [Permutation (Either a a)]
gs' = [ ([(Either a a, Either a a)] -> Permutation (Either a a)
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(Either a a, Either a a)] -> Permutation (Either a a))
-> (Permutation a -> [(Either a a, Either a a)])
-> Permutation a
-> Permutation (Either a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, a) -> (Either a a, Either a a))
-> [(a, a)] -> [(Either a a, Either a a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a :: a
a,b :: a
b) -> (a -> Either a a
lr a
a, a -> Either a a
lr a
b)) ([(a, a)] -> [(Either a a, Either a a)])
-> (Permutation a -> [(a, a)])
-> Permutation a
-> [(Either a a, Either a a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation a -> [(a, a)]
forall a. Permutation a -> [(a, a)]
toPairs) Permutation a
g | Permutation a
g <- [Permutation a]
gs]
    lr :: a -> Either a a
lr x :: a
x = if a
x a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
delta then a -> Either a a
forall a b. a -> Either a b
Left a
x else a -> Either a a
forall a b. b -> Either a b
Right a
x


{-
-- !! NEXT TWO FUNCTIONS NOT TESTED
-- Need some meaningful examples of homomorphisms
-- eg Sn -> Sym(k-subsets of n)
-- restrict to a transitive constituent
-- blocks

-- Given generators gs for a group G, and f : G -> H a homomorphism,
-- return the "semi-diagonal" subgroup [(f g, g) | g <- gs] of f(G) * G
homomorphismConstruction :: (Ord a, Ord b) => [Permutation a] -> (Permutation a -> Permutation b) -> [Permutation (Either b a)]
homomorphismConstruction gs f = [lift g | g <- gs] where
    lift g = fromPairs $ [(Right x, Right y) | (x,y) <- toPairs g] ++ [(Left x', Left y') | (x',y') <- toPairs (f g)] 

ker gs f = ks where
    gbar = homomorphismConstruction gs f
    gs' = sgs gbar
    ks' = dropWhile (\h -> isLeft $ minsupp h) gs' -- !! should filter isRight - sgs might not be in order
    ks = map unRight ks'
    unRight = fromPairs . map (\(Right a, Right b) -> (a,b)) . toPairs
-}


isTransitive :: (Ord t) => [Permutation t] -> Bool
isTransitive :: [Permutation t] -> Bool
isTransitive gs :: [Permutation t]
gs = [[t]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Permutation t] -> [[t]]
forall a. Ord a => [Permutation a] -> [[a]]
orbits [Permutation t]
gs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1


-- TRANSITIVE CONSTITUENTS

{-
-- find largest composition factor of a group which is not transitive
-- we do this by taking the smallest orbit delta,
-- then constructing the homomorphism G -> Sym(delta)
-- and returning the kernel and the image
factorNotTransitive gs = transitiveConstituentHomomorphism' gs delta where
    delta = smallest $ orbits gs
    sizeSorted lists = map snd $ L.sort $ [(length l, l) | l <- lists]
    smallest = head . sizeSorted
-}

-- Seress p81
-- |Given a group gs and a transitive constituent ys, return the kernel and image of the transitive constituent homomorphism.
-- That is, suppose that gs acts on a set xs, and ys is a subset of xs on which gs acts transitively.
-- Then the transitive constituent homomorphism is the restriction of the action of gs to an action on the ys.
transitiveConstituentHomomorphism
  :: (Ord a, Show a) =>
     [Permutation a] -> [a] -> ([Permutation a], [Permutation a])
transitiveConstituentHomomorphism :: [Permutation a] -> [a] -> ([Permutation a], [Permutation a])
transitiveConstituentHomomorphism gs :: [Permutation a]
gs delta :: [a]
delta
    | [a]
delta [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> [a -> a] -> [a]
forall a. Ord a => [a] -> [a -> a] -> [a]
closure [a]
delta [(a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g) | Permutation a
g <- [Permutation a]
gs] -- delta is closed under action of gs, hence a union of orbits
        = [Permutation a] -> [a] -> ([Permutation a], [Permutation a])
forall (t :: * -> *) b.
(Foldable t, Show b, Ord b) =>
[Permutation b] -> t b -> ([Permutation b], [Permutation b])
transitiveConstituentHomomorphism' [Permutation a]
gs [a]
delta

transitiveConstituentHomomorphism' :: [Permutation b] -> t b -> ([Permutation b], [Permutation b])
transitiveConstituentHomomorphism' gs :: [Permutation b]
gs delta :: t b
delta = ([Permutation b]
ker, [Permutation b]
im) where
    gs' :: [Permutation (Either b b)]
gs' = [Permutation (Either b b)] -> [Permutation (Either b b)]
forall a. (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs ([Permutation (Either b b)] -> [Permutation (Either b b)])
-> [Permutation (Either b b)] -> [Permutation (Either b b)]
forall a b. (a -> b) -> a -> b
$ (Permutation b -> Permutation (Either b b))
-> [Permutation b] -> [Permutation (Either b b)]
forall a b. (a -> b) -> [a] -> [b]
map ([(Either b b, Either b b)] -> Permutation (Either b b)
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(Either b b, Either b b)] -> Permutation (Either b b))
-> (Permutation b -> [(Either b b, Either b b)])
-> Permutation b
-> Permutation (Either b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, b) -> (Either b b, Either b b))
-> [(b, b)] -> [(Either b b, Either b b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a :: b
a,b :: b
b) -> (b -> Either b b
lr b
a, b -> Either b b
lr b
b)) ([(b, b)] -> [(Either b b, Either b b)])
-> (Permutation b -> [(b, b)])
-> Permutation b
-> [(Either b b, Either b b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation b -> [(b, b)]
forall a. Permutation a -> [(a, a)]
toPairs) [Permutation b]
gs
    -- as delta is a transitive constituent, we will always have a and b either both Left or both Right
    lr :: b -> Either b b
lr x :: b
x = if b
x b -> t b -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t b
delta then b -> Either b b
forall a b. a -> Either a b
Left b
x else b -> Either b b
forall a b. b -> Either a b
Right b
x
    ker :: [Permutation b]
ker = (Permutation (Either b b) -> Permutation b)
-> [Permutation (Either b b)] -> [Permutation b]
forall a b. (a -> b) -> [a] -> [b]
map Permutation (Either b b) -> Permutation b
forall a a. Ord a => Permutation (Either a a) -> Permutation a
unRight ([Permutation (Either b b)] -> [Permutation b])
-> [Permutation (Either b b)] -> [Permutation b]
forall a b. (a -> b) -> a -> b
$ (Permutation (Either b b) -> Bool)
-> [Permutation (Either b b)] -> [Permutation (Either b b)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Either b b -> Bool
forall a b. Either a b -> Bool
isLeft (Either b b -> Bool)
-> (Permutation (Either b b) -> Either b b)
-> Permutation (Either b b)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation (Either b b) -> Either b b
forall c. Permutation c -> c
minsupp) [Permutation (Either b b)]
gs' -- pointwise stabiliser of delta
    im :: [Permutation b]
im = (Permutation (Either b b) -> Permutation b)
-> [Permutation (Either b b)] -> [Permutation b]
forall a b. (a -> b) -> [a] -> [b]
map Permutation (Either b b) -> Permutation b
forall a b. Ord a => Permutation (Either a b) -> Permutation a
restrictLeft ([Permutation (Either b b)] -> [Permutation b])
-> [Permutation (Either b b)] -> [Permutation b]
forall a b. (a -> b) -> a -> b
$ (Permutation (Either b b) -> Bool)
-> [Permutation (Either b b)] -> [Permutation (Either b b)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Either b b -> Bool
forall a b. Either a b -> Bool
isLeft (Either b b -> Bool)
-> (Permutation (Either b b) -> Either b b)
-> Permutation (Either b b)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation (Either b b) -> Either b b
forall c. Permutation c -> c
minsupp) [Permutation (Either b b)]
gs' -- restriction of the action to delta


-- BLOCKS OF IMPRIMITIVITY

-- Holt p83ff (and also Seress p107ff)
-- Find a minimal block containing ys. ys are assumed to be sorted.
minimalBlock :: [Permutation a] -> [a] -> [[a]]
minimalBlock gs :: [Permutation a]
gs ys :: [a]
ys@(y1 :: a
y1:yt :: [a]
yt) = Map a a -> [a] -> [Permutation a] -> [[a]]
minimalBlock' Map a a
p [a]
yt [Permutation a]
gs where
    xs :: [a]
xs = ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
union [] ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (Permutation a -> [a]) -> [Permutation a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> [a]
forall a. Permutation a -> [a]
supp [Permutation a]
gs
    p :: Map a a
p = [(a, a)] -> Map a a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, a)] -> Map a a) -> [(a, a)] -> Map a a
forall a b. (a -> b) -> a -> b
$ [(a
yi,a
y1) | a
yi <- [a]
ys] [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a
x,a
x) | a
x <- [a]
xs [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
\\ [a]
ys]
    minimalBlock' :: Map a a -> [a] -> [Permutation a] -> [[a]]
minimalBlock' p :: Map a a
p (q :: a
q:qs :: [a]
qs) (h :: Permutation a
h:hs :: [Permutation a]
hs) =
        let r :: a
r = Map a a
p Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! a
q         -- representative of class containing q
            k :: a
k = Map a a
p Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! (a
q a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
h)  -- rep of class (q^h)
            l :: a
l = Map a a
p Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! (a
r a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
h)  -- rep of class (r^h)
        in if a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
l -- then we need to merge the classes
           then let p' :: Map a a
p' = (a -> a) -> Map a a -> Map a a
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\x :: a
x -> if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
l then a
k else a
x) Map a a
p
                    qs' :: [a]
qs' = [a]
qs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
l]
                in Map a a -> [a] -> [Permutation a] -> [[a]]
minimalBlock' Map a a
p' (a
qa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
qs') [Permutation a]
hs
           else Map a a -> [a] -> [Permutation a] -> [[a]]
minimalBlock' Map a a
p (a
qa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
qs) [Permutation a]
hs
    minimalBlock' p :: Map a a
p (q :: a
q:qs :: [a]
qs) [] = Map a a -> [a] -> [Permutation a] -> [[a]]
minimalBlock' Map a a
p [a]
qs [Permutation a]
gs
    minimalBlock' p :: Map a a
p [] _ =
        let reps :: [a]
reps = [a] -> [a]
forall b. Ord b => [b] -> [b]
toListSet ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Map a a -> [a]
forall k a. Map k a -> [a]
M.elems Map a a
p
        in [[a]] -> [[a]]
forall b. Ord b => [b] -> [b]
L.sort [ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: a
x -> Map a a
p Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
r) [a]
xs | a
r <- [a]
reps ]
-- Because the support of the permutations is not constrained to be [1..n], we have to use a map instead of an array
-- This probably affects the complexity, but isn't a problem in practice

-- |Given a transitive group gs, find all non-trivial block systems. That is, if gs act on xs,
-- find all the ways that the xs can be divided into blocks, such that the gs also have a permutation action on the blocks
blockSystems :: (Ord t) => [Permutation t] -> [[[t]]]
blockSystems :: [Permutation t] -> [[[t]]]
blockSystems gs :: [Permutation t]
gs
    | [Permutation t] -> Bool
forall t. Ord t => [Permutation t] -> Bool
isTransitive [Permutation t]
gs = [[[t]]] -> [[[t]]]
forall b. Ord b => [b] -> [b]
toListSet ([[[t]]] -> [[[t]]]) -> [[[t]]] -> [[[t]]]
forall a b. (a -> b) -> a -> b
$ ([[t]] -> Bool) -> [[[t]]] -> [[[t]]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([[t]] -> [[t]] -> Bool
forall a. Eq a => a -> a -> Bool
/= [t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
xs]) ([[[t]]] -> [[[t]]]) -> [[[t]]] -> [[[t]]]
forall a b. (a -> b) -> a -> b
$ ([t] -> [[t]]) -> [[t]] -> [[[t]]]
forall a b. (a -> b) -> [a] -> [b]
map ([Permutation t] -> [t] -> [[t]]
forall a. Ord a => [Permutation a] -> [a] -> [[a]]
minimalBlock [Permutation t]
gs) [ [t
x,t
x'] | t
x' <- [t]
xs ]
    | Bool
otherwise = [Char] -> [[[t]]]
forall a. HasCallStack => [Char] -> a
error "blockSystems: not transitive"
    where x :: t
x:xs :: [t]
xs = ([t] -> [t] -> [t]) -> [t] -> [[t]] -> [t]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [t] -> [t] -> [t]
forall a. Ord a => [a] -> [a] -> [a]
union [] ([[t]] -> [t]) -> [[t]] -> [t]
forall a b. (a -> b) -> a -> b
$ (Permutation t -> [t]) -> [Permutation t] -> [[t]]
forall a b. (a -> b) -> [a] -> [b]
map Permutation t -> [t]
forall a. Permutation a -> [a]
supp [Permutation t]
gs


-- |A more efficient version of blockSystems, if we have an sgs
blockSystemsSGS :: (Ord a) => [Permutation a] -> [[[a]]]
blockSystemsSGS :: [Permutation a] -> [[[a]]]
blockSystemsSGS gs :: [Permutation a]
gs = [[[a]]] -> [[[a]]]
forall b. Ord b => [b] -> [b]
toListSet ([[[a]]] -> [[[a]]]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> a -> b
$ ([[a]] -> Bool) -> [[[a]]] -> [[[a]]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([[a]] -> [[a]] -> Bool
forall a. Eq a => a -> a -> Bool
/= [a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs]) ([[[a]]] -> [[[a]]]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [[a]]) -> [[a]] -> [[[a]]]
forall a b. (a -> b) -> [a] -> [b]
map ([Permutation a] -> [a] -> [[a]]
forall a. Ord a => [Permutation a] -> [a] -> [[a]]
minimalBlock [Permutation a]
gs) [ [a
x,a
x'] | a
x' <- [a]
rs ]
    where x :: a
x:xs :: [a]
xs = ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
union [] ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (Permutation a -> [a]) -> [Permutation a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> [a]
forall a. Permutation a -> [a]
supp [Permutation a]
gs
          hs :: [Permutation a]
hs = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\g :: Permutation a
g -> a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< Permutation a -> a
forall c. Permutation c -> c
minsupp Permutation a
g) [Permutation a]
gs -- sgs for stabiliser Gx
          os :: [[a]]
os = [Permutation a] -> [[a]]
forall a. Ord a => [Permutation a] -> [[a]]
orbits [Permutation a]
hs
          rs :: [a]
rs = ([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> a
forall a. [a] -> a
head [[a]]
os [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ([a]
xs [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
\\ [a] -> [a]
forall b. Ord b => [b] -> [b]
L.sort ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
os)) -- orbit representatives, including singleton cycles
-- Perhaps we could have a function which just returns orbit reps for stabiliser

-- eg for D 10, the stabiliser of 1 is [[2,6],[3,5]] - we need to make sure we don't forget 4

-- If we didn't have an SGS, we could try to randomly generate a few elts of stabiliser Gx, as that would still be better than nothing
-- see Holt RandomStab function


-- |A permutation group is primitive if it has no non-trivial block systems
isPrimitive :: (Ord t) => [Permutation t] -> Bool
isPrimitive :: [Permutation t] -> Bool
isPrimitive gs :: [Permutation t]
gs = [[[t]]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Permutation t] -> [[[t]]]
forall t. Ord t => [Permutation t] -> [[[t]]]
blockSystems [Permutation t]
gs)

isPrimitiveSGS :: (Ord a) => [Permutation a] -> Bool
isPrimitiveSGS :: [Permutation a] -> Bool
isPrimitiveSGS gs :: [Permutation a]
gs = [[[a]]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Permutation a] -> [[[a]]]
forall t. Ord t => [Permutation t] -> [[[t]]]
blockSystemsSGS [Permutation a]
gs)

-- There are other optimisations we haven't done
-- see Holt p86

-- |Given a transitive group gs, and a block system for gs, return the kernel and image of the block homomorphism
-- (the homomorphism onto the action of gs on the blocks)
blockHomomorphism
  :: (Ord t, Show t) =>
     [Permutation t] -> [[t]] -> ([Permutation t], [Permutation [t]])
blockHomomorphism :: [Permutation t] -> [[t]] -> ([Permutation t], [Permutation [t]])
blockHomomorphism gs :: [Permutation t]
gs bs :: [[t]]
bs
    | [[t]]
bs [[t]] -> [[t]] -> Bool
forall a. Eq a => a -> a -> Bool
== [[t]] -> [[t] -> [t]] -> [[t]]
forall a. Ord a => [a] -> [a -> a] -> [a]
closure [[t]]
bs [([t] -> Permutation t -> [t]
forall a. Ord a => [a] -> Permutation a -> [a]
-^ Permutation t
g) | Permutation t
g <- [Permutation t]
gs] -- bs is closed under action of gs
        = [Permutation t] -> [[t]] -> ([Permutation t], [Permutation [t]])
forall b.
(Show b, Ord b) =>
[Permutation b] -> [[b]] -> ([Permutation b], [Permutation [b]])
blockHomomorphism' [Permutation t]
gs [[t]]
bs

blockHomomorphism' :: [Permutation b] -> [[b]] -> ([Permutation b], [Permutation [b]])
blockHomomorphism' gs :: [Permutation b]
gs bs :: [[b]]
bs = ([Permutation b]
ker,[Permutation [b]]
im) where
    gs' :: [Permutation (Either [b] b)]
gs' = [Permutation (Either [b] b)] -> [Permutation (Either [b] b)]
forall a. (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs ([Permutation (Either [b] b)] -> [Permutation (Either [b] b)])
-> [Permutation (Either [b] b)] -> [Permutation (Either [b] b)]
forall a b. (a -> b) -> a -> b
$ (Permutation b -> Permutation (Either [b] b))
-> [Permutation b] -> [Permutation (Either [b] b)]
forall a b. (a -> b) -> [a] -> [b]
map Permutation b -> Permutation (Either [b] b)
lr [Permutation b]
gs
    lr :: Permutation b -> Permutation (Either [b] b)
lr g :: Permutation b
g = [(Either [b] b, Either [b] b)] -> Permutation (Either [b] b)
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(Either [b] b, Either [b] b)] -> Permutation (Either [b] b))
-> [(Either [b] b, Either [b] b)] -> Permutation (Either [b] b)
forall a b. (a -> b) -> a -> b
$ [([b] -> Either [b] b
forall a b. a -> Either a b
Left [b]
b, [b] -> Either [b] b
forall a b. a -> Either a b
Left ([b] -> Either [b] b) -> [b] -> Either [b] b
forall a b. (a -> b) -> a -> b
$ [b]
b [b] -> Permutation b -> [b]
forall a. Ord a => [a] -> Permutation a -> [a]
-^ Permutation b
g) | [b]
b <- [[b]]
bs] [(Either [b] b, Either [b] b)]
-> [(Either [b] b, Either [b] b)] -> [(Either [b] b, Either [b] b)]
forall a. [a] -> [a] -> [a]
++ [(b -> Either [b] b
forall a b. b -> Either a b
Right b
x, b -> Either [b] b
forall a b. b -> Either a b
Right b
y) | (x :: b
x,y :: b
y) <- Permutation b -> [(b, b)]
forall a. Permutation a -> [(a, a)]
toPairs Permutation b
g]
    ker :: [Permutation b]
ker = (Permutation (Either [b] b) -> Permutation b)
-> [Permutation (Either [b] b)] -> [Permutation b]
forall a b. (a -> b) -> [a] -> [b]
map Permutation (Either [b] b) -> Permutation b
forall a a. Ord a => Permutation (Either a a) -> Permutation a
unRight ([Permutation (Either [b] b)] -> [Permutation b])
-> [Permutation (Either [b] b)] -> [Permutation b]
forall a b. (a -> b) -> a -> b
$ (Permutation (Either [b] b) -> Bool)
-> [Permutation (Either [b] b)] -> [Permutation (Either [b] b)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Either [b] b -> Bool
forall a b. Either a b -> Bool
isLeft (Either [b] b -> Bool)
-> (Permutation (Either [b] b) -> Either [b] b)
-> Permutation (Either [b] b)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation (Either [b] b) -> Either [b] b
forall c. Permutation c -> c
minsupp) [Permutation (Either [b] b)]
gs' -- stabiliser of the blocks
    im :: [Permutation [b]]
im = (Permutation (Either [b] b) -> Permutation [b])
-> [Permutation (Either [b] b)] -> [Permutation [b]]
forall a b. (a -> b) -> [a] -> [b]
map Permutation (Either [b] b) -> Permutation [b]
forall a b. Ord a => Permutation (Either a b) -> Permutation a
restrictLeft ([Permutation (Either [b] b)] -> [Permutation [b]])
-> [Permutation (Either [b] b)] -> [Permutation [b]]
forall a b. (a -> b) -> a -> b
$ (Permutation (Either [b] b) -> Bool)
-> [Permutation (Either [b] b)] -> [Permutation (Either [b] b)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Either [b] b -> Bool
forall a b. Either a b -> Bool
isLeft (Either [b] b -> Bool)
-> (Permutation (Either [b] b) -> Either [b] b)
-> Permutation (Either [b] b)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation (Either [b] b) -> Either [b] b
forall c. Permutation c -> c
minsupp) [Permutation (Either [b] b)]
gs' -- restriction to the action on blocks

-- Note that there is a slightly more efficient way to calculate block homomorphism,
-- but requires change of base algorithm which we haven't implemented yet


-- NORMAL CLOSURE

-- Seress 115
-- Given G, H < Sym(Omega) return <H^G> (the normal closure)
normalClosure :: [Permutation a] -> [Permutation a] -> [Permutation a]
normalClosure gs :: [Permutation a]
gs hs :: [Permutation a]
hs = (Permutation (Either a a) -> Permutation a)
-> [Permutation (Either a a)] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map Permutation (Either a a) -> Permutation a
forall a a. Ord a => Permutation (Either a a) -> Permutation a
unRight ([Permutation (Either a a)] -> [Permutation a])
-> [Permutation (Either a a)] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (Permutation (Either a a) -> Bool)
-> [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Either a a -> Bool
forall a b. Either a b -> Bool
isLeft (Either a a -> Bool)
-> (Permutation (Either a a) -> Either a a)
-> Permutation (Either a a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation (Either a a) -> Either a a
forall c. Permutation c -> c
minsupp) ([Permutation (Either a a)] -> [Permutation (Either a a)])
-> [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a b. (a -> b) -> a -> b
$ [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a. (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs [Permutation (Either a a)]
ks where
    xs :: [a]
xs = ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
union [] ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (Permutation a -> [a]) -> [Permutation a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> [a]
forall a. Permutation a -> [a]
supp ([Permutation a] -> [[a]]) -> [Permutation a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [Permutation a]
gs [Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++ [Permutation a]
hs
    ds :: [Permutation (Either a a)]
ds = (Permutation a -> Permutation (Either a a))
-> [Permutation a] -> [Permutation (Either a a)]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> Permutation (Either a a)
forall b. Ord b => Permutation b -> Permutation (Either b b)
diag [Permutation a]
gs -- {(g,g) | g <- G}
    diag :: Permutation b -> Permutation (Either b b)
diag g :: Permutation b
g = [(Either b b, Either b b)] -> Permutation (Either b b)
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(Either b b, Either b b)] -> Permutation (Either b b))
-> [(Either b b, Either b b)] -> Permutation (Either b b)
forall a b. (a -> b) -> a -> b
$ [[(Either b b, Either b b)]] -> [(Either b b, Either b b)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(b -> Either b b
forall a b. a -> Either a b
Left b
x, b -> Either b b
forall a b. a -> Either a b
Left b
y) , (b -> Either b b
forall a b. b -> Either a b
Right b
x, b -> Either b b
forall a b. b -> Either a b
Right b
y)] | (x :: b
x,y :: b
y) <- Permutation b -> [(b, b)]
forall a. Permutation a -> [(a, a)]
toPairs Permutation b
g]
    hsR :: [Permutation (Either a a)]
hsR = (Permutation a -> Permutation (Either a a))
-> [Permutation a] -> [Permutation (Either a a)]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> Permutation (Either a a)
forall a b.
(Ord a, Ord b) =>
Permutation b -> Permutation (Either a b)
inR [Permutation a]
hs -- {(1,h) | h <- H}
    inR :: Permutation b -> Permutation (Either a b)
inR h :: Permutation b
h = [(Either a b, Either a b)] -> Permutation (Either a b)
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [(b -> Either a b
forall a b. b -> Either a b
Right b
x, b -> Either a b
forall a b. b -> Either a b
Right b
y) | (x :: b
x,y :: b
y) <- Permutation b -> [(b, b)]
forall a. Permutation a -> [(a, a)]
toPairs Permutation b
h]
    ks :: [Permutation (Either a a)]
ks = [Permutation (Either a a)]
ds [Permutation (Either a a)]
-> [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a. [a] -> [a] -> [a]
++ [Permutation (Either a a)]
forall a. Ord a => [Permutation (Either a a)]
hsR

-- Seress 116
-- Given G, H < Sym(Omega) return <H^G> `intersection` G
intersectionNormalClosure :: [Permutation a] -> [Permutation a] -> [Permutation a]
intersectionNormalClosure gs :: [Permutation a]
gs hs :: [Permutation a]
hs = (Permutation (Either a a) -> Permutation a)
-> [Permutation (Either a a)] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map Permutation (Either a a) -> Permutation a
forall a a. Ord a => Permutation (Either a a) -> Permutation a
unRight ([Permutation (Either a a)] -> [Permutation a])
-> [Permutation (Either a a)] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (Permutation (Either a a) -> Bool)
-> [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Either a a -> Bool
forall a b. Either a b -> Bool
isLeft (Either a a -> Bool)
-> (Permutation (Either a a) -> Either a a)
-> Permutation (Either a a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation (Either a a) -> Either a a
forall c. Permutation c -> c
minsupp) ([Permutation (Either a a)] -> [Permutation (Either a a)])
-> [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a b. (a -> b) -> a -> b
$ [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a. (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs [Permutation (Either a a)]
ks where
    xs :: [a]
xs = ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
union [] ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (Permutation a -> [a]) -> [Permutation a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> [a]
forall a. Permutation a -> [a]
supp ([Permutation a] -> [[a]]) -> [Permutation a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [Permutation a]
gs [Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++ [Permutation a]
hs
    ds :: [Permutation (Either a a)]
ds = (Permutation a -> Permutation (Either a a))
-> [Permutation a] -> [Permutation (Either a a)]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> Permutation (Either a a)
forall b. Ord b => Permutation b -> Permutation (Either b b)
diag [Permutation a]
gs -- {(g,g) | g <- G}
    diag :: Permutation b -> Permutation (Either b b)
diag g :: Permutation b
g = [(Either b b, Either b b)] -> Permutation (Either b b)
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(Either b b, Either b b)] -> Permutation (Either b b))
-> [(Either b b, Either b b)] -> Permutation (Either b b)
forall a b. (a -> b) -> a -> b
$ [[(Either b b, Either b b)]] -> [(Either b b, Either b b)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(b -> Either b b
forall a b. a -> Either a b
Left b
x, b -> Either b b
forall a b. a -> Either a b
Left b
y) , (b -> Either b b
forall a b. b -> Either a b
Right b
x, b -> Either b b
forall a b. b -> Either a b
Right b
y)] | (x :: b
x,y :: b
y) <- Permutation b -> [(b, b)]
forall a. Permutation a -> [(a, a)]
toPairs Permutation b
g]
    hsL :: [Permutation (Either a b)]
hsL = (Permutation a -> Permutation (Either a b))
-> [Permutation a] -> [Permutation (Either a b)]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> Permutation (Either a b)
forall a b.
(Ord a, Ord b) =>
Permutation a -> Permutation (Either a b)
inL [Permutation a]
hs -- {(h,1) | h <- H}
    inL :: Permutation a -> Permutation (Either a b)
inL h :: Permutation a
h = [(Either a b, Either a b)] -> Permutation (Either a b)
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [(a -> Either a b
forall a b. a -> Either a b
Left a
x, a -> Either a b
forall a b. a -> Either a b
Left a
y) | (x :: a
x,y :: a
y) <- Permutation a -> [(a, a)]
forall a. Permutation a -> [(a, a)]
toPairs Permutation a
h]
    ks :: [Permutation (Either a a)]
ks = [Permutation (Either a a)]
ds [Permutation (Either a a)]
-> [Permutation (Either a a)] -> [Permutation (Either a a)]
forall a. [a] -> [a] -> [a]
++ [Permutation (Either a a)]
forall b. Ord b => [Permutation (Either a b)]
hsL


-- CENTRALISER IN THE SYMMETRIC GROUP

-- Centralizer of G in Sym(X) - transitive case
centralizerSymTrans :: [Permutation a] -> [Permutation a]
centralizerSymTrans gs :: [Permutation a]
gs = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Permutation a -> Permutation a -> Bool
forall a. Eq a => a -> a -> Bool
/= 1) ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ [Permutation a] -> [a] -> [Permutation a]
centralizerSymTrans' [] [a]
fix_g_a where
    xs :: [a]
xs@(a :: a
a:_) = ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
union [] ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (Permutation a -> [a]) -> [Permutation a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> [a]
forall a. Permutation a -> [a]
supp [Permutation a]
gs
    ss :: [Permutation a]
ss = [Permutation a] -> [Permutation a]
forall a. (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs [Permutation a]
gs
    g_a :: [Permutation a]
g_a = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ( (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
a) (a -> Bool) -> (Permutation a -> a) -> Permutation a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation a -> a
forall c. Permutation c -> c
minsupp ) [Permutation a]
ss -- pt stabiliser of a
    fix_g_a :: [a]
fix_g_a = [a]
xs [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
\\ (([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
union [] ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (Permutation a -> [a]) -> [Permutation a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> [a]
forall a. Permutation a -> [a]
supp [Permutation a]
g_a) -- the pts fixed by stabiliser of a
    reps_a :: Map a (Permutation a)
reps_a = [Permutation a] -> a -> Map a (Permutation a)
forall k. Ord k => [Permutation k] -> k -> Map k (Permutation k)
cosetRepsGx [Permutation a]
gs a
a
    -- xs = M.keys reps_a
    centralizingElt :: a -> Permutation a
centralizingElt b :: a
b = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [ let g :: Permutation a
g = Map a (Permutation a)
reps_a Map a (Permutation a) -> a -> Permutation a
forall k a. Ord k => Map k a -> k -> a
M.! a
x in (a
x, a
b a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g) | a
x <- [a]
xs ]
    centralizerSymTrans' :: [Permutation a] -> [a] -> [Permutation a]
centralizerSymTrans' ls :: [Permutation a]
ls (r :: a
r:rs :: [a]
rs) =
        let c :: Permutation a
c = a -> Permutation a
centralizingElt a
r
        in Permutation a
c Permutation a -> [Permutation a] -> [Permutation a]
forall a. a -> [a] -> [a]
: [Permutation a] -> [a] -> [Permutation a]
centralizerSymTrans' (Permutation a
cPermutation a -> [Permutation a] -> [Permutation a]
forall a. a -> [a] -> [a]
:[Permutation a]
ls) ([a]
rs [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
\\ [Permutation a] -> a -> [a]
forall t. Ord t => [Permutation t] -> t -> [t]
orbitP (Permutation a
cPermutation a -> [Permutation a] -> [Permutation a]
forall a. a -> [a] -> [a]
:[Permutation a]
ls) a
a)
    centralizerSymTrans' _ [] = []