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


{-# LANGUAGE NoMonomorphismRestriction #-}

-- |A module for doing arithmetic in permutation groups.

--

-- Group elements are represented as permutations of underlying sets, and are entered and displayed

-- using a Haskell-friendly version of cycle notation. For example, the permutation (1 2 3)(4 5)

-- would be entered as @p [[1,2,3],[4,5]]@, and displayed as [[1,2,3],[4,5]]. Permutations can be defined

-- over arbitrary underlying sets (types), not just the integers.

--

-- If @g@ and @h@ are group elements, then the expressions @g*h@ and @g^-1@ calculate product and inverse respectively.

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, (\\) ) -- a version of union which assumes the arguments are ascending sets (no repeated elements)


import Math.Core.Utils hiding (elts)
import Math.Algebra.LinearAlgebra hiding (inverse) -- only needed for use in ghci


infix 8 ~^

rotateL :: [a] -> [a]
rotateL (x :: a
x:xs :: [a]
xs) = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]


-- PERMUTATIONS


-- |A type for permutations, considered as functions or actions which can be performed on an underlying set.

newtype Permutation a = P (M.Map a a) deriving (Permutation a -> Permutation a -> Bool
(Permutation a -> Permutation a -> Bool)
-> (Permutation a -> Permutation a -> Bool) -> Eq (Permutation a)
forall a. Eq a => Permutation a -> Permutation a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Permutation a -> Permutation a -> Bool
$c/= :: forall a. Eq a => Permutation a -> Permutation a -> Bool
== :: Permutation a -> Permutation a -> Bool
$c== :: forall a. Eq a => Permutation a -> Permutation a -> Bool
Eq,Eq (Permutation a)
Eq (Permutation a) =>
(Permutation a -> Permutation a -> Ordering)
-> (Permutation a -> Permutation a -> Bool)
-> (Permutation a -> Permutation a -> Bool)
-> (Permutation a -> Permutation a -> Bool)
-> (Permutation a -> Permutation a -> Bool)
-> (Permutation a -> Permutation a -> Permutation a)
-> (Permutation a -> Permutation a -> Permutation a)
-> Ord (Permutation a)
Permutation a -> Permutation a -> Bool
Permutation a -> Permutation a -> Ordering
Permutation a -> Permutation a -> Permutation a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Permutation a)
forall a. Ord a => Permutation a -> Permutation a -> Bool
forall a. Ord a => Permutation a -> Permutation a -> Ordering
forall a. Ord a => Permutation a -> Permutation a -> Permutation a
min :: Permutation a -> Permutation a -> Permutation a
$cmin :: forall a. Ord a => Permutation a -> Permutation a -> Permutation a
max :: Permutation a -> Permutation a -> Permutation a
$cmax :: forall a. Ord a => Permutation a -> Permutation a -> Permutation a
>= :: Permutation a -> Permutation a -> Bool
$c>= :: forall a. Ord a => Permutation a -> Permutation a -> Bool
> :: Permutation a -> Permutation a -> Bool
$c> :: forall a. Ord a => Permutation a -> Permutation a -> Bool
<= :: Permutation a -> Permutation a -> Bool
$c<= :: forall a. Ord a => Permutation a -> Permutation a -> Bool
< :: Permutation a -> Permutation a -> Bool
$c< :: forall a. Ord a => Permutation a -> Permutation a -> Bool
compare :: Permutation a -> Permutation a -> Ordering
$ccompare :: forall a. Ord a => Permutation a -> Permutation a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Permutation a)
Ord)

-- Can't make a Functor instance because we need an Ord instance

fmapP :: (t -> a) -> Permutation t -> Permutation a
fmapP f :: t -> a
f = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a)
-> (Permutation t -> [(a, a)]) -> Permutation t -> Permutation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((t, t) -> (a, a)) -> [(t, t)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: t
x,y :: t
y) -> (t -> a
f t
x, t -> a
f t
y)) ([(t, t)] -> [(a, a)])
-> (Permutation t -> [(t, t)]) -> Permutation t -> [(a, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation t -> [(t, t)]
forall a. Permutation a -> [(a, a)]
toPairs

-- |Construct a permutation from a list of cycles.

-- For example, @p [[1,2,3],[4,5]]@ returns the permutation that sends 1 to 2, 2 to 3, 3 to 1, 4 to 5, 5 to 4.

p :: (Ord a) => [[a]] -> Permutation a
p :: [[a]] -> Permutation a
p = [[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
fromCycles

fromPairs :: [(a, a)] -> Permutation a
fromPairs xys :: [(a, a)]
xys | Bool
isValid   = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs' [(a, a)]
xys
              | Bool
otherwise = [Char] -> Permutation a
forall a. HasCallStack => [Char] -> a
error "Not a permutation"
    where (xs :: [a]
xs,ys :: [a]
ys) = [(a, a)] -> ([a], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a, a)]
xys
          (xs' :: [a]
xs',ys' :: [a]
ys') = ([a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a]
xs, [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a]
ys)
          isValid :: Bool
isValid = [a]
xs' [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
ys' Bool -> Bool -> Bool
&& ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==1) (Int -> Bool) -> ([a] -> Int) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
L.group [a]
xs') -- ie the domain and range are the same, and are *sets*


fromPairs' :: [(a, a)] -> Permutation a
fromPairs' xys :: [(a, a)]
xys = Map a a -> Permutation a
forall a. Map a a -> Permutation a
P (Map a a -> Permutation a) -> Map a a -> Permutation a
forall a b. (a -> b) -> a -> b
$ [(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, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool) -> (a, a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) [(a, a)]
xys
-- we remove fixed points, so that the derived Eq instance works as expected


toPairs :: Permutation a -> [(a, a)]
toPairs (P g :: Map a a
g) = Map a a -> [(a, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map a a
g

fromList :: [a] -> Permutation a
fromList xs :: [a]
xs = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a) -> [(a, a)] -> Permutation a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs ([a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a]
xs)
-- for example, fromList [2,3,1] is [[1,3,2]] - because the 1 moved to the 3 position


-- the support of a permutation is the points it moves (returned in ascending order)

supp :: Permutation a -> [a]
supp (P g :: Map a a
g) = Map a a -> [a]
forall k a. Map k a -> [k]
M.keys Map a a
g
-- (This is guaranteed not to contain fixed points provided the permutations have been constructed using the supplied constructors)


-- |x .^ g returns the image of a vertex or point x under the action of the permutation g.

-- For example, @1 .^ p [[1,2,3]]@ returns 2.

-- The dot is meant to be a mnemonic for point or vertex.

(.^) :: (Ord a) => a -> Permutation a -> a
x :: a
x .^ :: a -> Permutation a -> a
.^ P g :: Map a a
g = case a -> Map a a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
x Map a a
g of
           Just y :: a
y  -> a
y
           Nothing -> a
x -- if x `notElem` supp (P g), then x is not moved


-- |b -^ g returns the image of an edge or block b under the action of the permutation g.

-- For example, @[1,2] -^ p [[1,4],[2,3]]@ returns [3,4].

-- The dash is meant to be a mnemonic for edge or line or block.

(-^) :: (Ord a) => [a] -> Permutation a -> [a]
xs :: [a]
xs -^ :: [a] -> Permutation a -> [a]
-^ g :: Permutation a
g = [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
x a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g | a
x <- [a]
xs]

-- construct a permutation from cycles

-- fromCycles cs = fromPairs $ concatMap fromCycle cs

fromCycles :: [[a]] -> Permutation a
fromCycles cs :: [[a]]
cs = [Permutation a] -> Permutation a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Permutation a] -> Permutation a)
-> [Permutation a] -> Permutation a
forall a b. (a -> b) -> a -> b
$ ([a] -> Permutation a) -> [[a]] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map ([(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a)
-> ([a] -> [(a, a)]) -> [a] -> Permutation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [(a, a)]
forall b. [b] -> [(b, b)]
fromCycle) [[a]]
cs
    where fromCycle :: [b] -> [(b, b)]
fromCycle xs :: [b]
xs = [b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [b]
xs ([b] -> [b]
forall a. [a] -> [a]
rotateL [b]
xs)

-- convert a permutation to cycles

toCycles :: Permutation a -> [[a]]
toCycles g :: Permutation a
g = [a] -> [[a]]
toCycles' ([a] -> [[a]]) -> [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ Permutation a -> [a]
forall a. Permutation a -> [a]
supp Permutation a
g
    where toCycles' :: [a] -> [[a]]
toCycles' ys :: [a]
ys@(y :: a
y:_) = let c :: [a]
c = Permutation a -> a -> [a]
forall t. Ord t => Permutation t -> t -> [t]
cycleOf Permutation a
g a
y in [a]
c [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
toCycles' ([a]
ys [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
c)
          toCycles' [] = []

cycleOf :: Permutation t -> t -> [t]
cycleOf g :: Permutation t
g x :: t
x = t -> [t] -> [t]
cycleOf' t
x [] where
    cycleOf' :: t -> [t] -> [t]
cycleOf' y :: t
y ys :: [t]
ys = let y' :: t
y' = t
y t -> Permutation t -> t
forall a. Ord a => a -> Permutation a -> a
.^ Permutation t
g in if t
y' t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
x then [t] -> [t]
forall a. [a] -> [a]
reverse (t
yt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
ys) else t -> [t] -> [t]
cycleOf' t
y' (t
yt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
ys)

instance (Ord a, Show a) => Show (Permutation a) where
    show :: Permutation a -> [Char]
show g :: Permutation a
g | Permutation a
g Permutation a -> Permutation a -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = "1"
           | Bool
otherwise = [[a]] -> [Char]
forall a. Show a => a -> [Char]
show (Permutation a -> [[a]]
forall a. Ord a => Permutation a -> [[a]]
toCycles Permutation a
g)

parity :: Permutation a -> Int
parity g :: Permutation a
g = let cs :: [[a]]
cs = Permutation a -> [[a]]
forall a. Ord a => Permutation a -> [[a]]
toCycles Permutation a
g in ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
cs) Int -> Int -> Int
forall a. Num a => a -> a -> a
- [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
cs) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 2
-- parity' g = length (filter (even . length) $ toCycles g) `mod` 2


sign :: Permutation a -> a
sign g :: Permutation a
g = (-1)a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^(Permutation a -> Int
forall a. Ord a => Permutation a -> Int
parity Permutation a
g)

orderElt :: Permutation a -> Int
orderElt g :: Permutation a
g = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Integral a => a -> a -> a
lcm 1 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[a]] -> [Int]) -> [[a]] -> [Int]
forall a b. (a -> b) -> a -> b
$ Permutation a -> [[a]]
forall a. Ord a => Permutation a -> [[a]]
toCycles Permutation a
g
-- == order [g]


-- |The Num instance is what enables us to write @g*h@ for the product of group elements and @1@ for the group identity.

-- Unfortunately we can't of course give sensible definitions for the other functions declared in the Num typeclass.

instance Ord a => Num (Permutation a) where
    g :: Permutation a
g * :: Permutation a -> Permutation a -> Permutation a
* h :: Permutation a
h = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs' [(a
x, a
x a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
h) | a
x <- Permutation a -> [a]
forall a. Permutation a -> [a]
supp Permutation a
g [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`union` Permutation a -> [a]
forall a. Permutation a -> [a]
supp Permutation a
h]
    -- signum = sign -- doesn't work, complains about no (+) instance

    fromInteger :: Integer -> Permutation a
fromInteger 1 = Map a a -> Permutation a
forall a. Map a a -> Permutation a
P (Map a a -> Permutation a) -> Map a a -> Permutation a
forall a b. (a -> b) -> a -> b
$ Map a a
forall k a. Map k a
M.empty
    _ + :: Permutation a -> Permutation a -> Permutation a
+ _ = [Char] -> Permutation a
forall a. HasCallStack => [Char] -> a
error "(Permutation a).+: not applicable"
    negate :: Permutation a -> Permutation a
negate _ = [Char] -> Permutation a
forall a. HasCallStack => [Char] -> a
error "(Permutation a).negate: not applicable"
    abs :: Permutation a -> Permutation a
abs _ = [Char] -> Permutation a
forall a. HasCallStack => [Char] -> a
error "(Permutation a).abs: not applicable"
    signum :: Permutation a -> Permutation a
signum _ = [Char] -> Permutation a
forall a. HasCallStack => [Char] -> a
error "(Permutation a).signum: not applicable"

-- |The HasInverses instance is what enables us to write @g^-1@ for the inverse of a group element.

instance Ord a => HasInverses (Permutation a) where
    inverse :: Permutation a -> Permutation a
inverse (P g :: Map a a
g) = Map a a -> Permutation a
forall a. Map a a -> Permutation a
P (Map a a -> Permutation a) -> Map a a -> Permutation a
forall a b. (a -> b) -> a -> b
$ [(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, a) -> (a, a)) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: a
x,y :: a
y)->(a
y,a
x)) ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ Map a a -> [(a, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map a a
g


-- |g ~^ h returns the conjugate of g by h, that is, h^-1*g*h.

-- The tilde is meant to a mnemonic, because conjugacy is an equivalence relation.

(~^) :: Ord a => Permutation a -> Permutation a -> Permutation a
g :: Permutation a
g ~^ :: Permutation a -> Permutation a -> Permutation a
~^ h :: Permutation a
h = Permutation a
hPermutation a -> Integer -> Permutation a
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1 Permutation a -> Permutation a -> Permutation a
forall a. Num a => a -> a -> a
* Permutation a
g Permutation a -> Permutation a -> Permutation a
forall a. Num a => a -> a -> a
* Permutation a
h

-- commutator

comm :: a -> a -> a
comm g :: a
g h :: a
h = a
ga -> Integer -> a
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1 a -> a -> a
forall a. Num a => a -> a -> a
* a
ha -> Integer -> a
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1 a -> a -> a
forall a. Num a => a -> a -> a
* a
g a -> a -> a
forall a. Num a => a -> a -> a
* a
h


-- ORBITS


{-
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'
-}
closureS :: [a] -> [a -> a] -> Set a
closureS xs :: [a]
xs fs :: [a -> a]
fs = Set a -> [a] -> Set a
closure' Set a
forall a. Set a
S.empty [a]
xs where
    closure' :: Set a -> [a] -> Set a
closure' interior :: Set a
interior (x :: a
x:xs :: [a]
xs)
        | a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member a
x Set a
interior = Set a -> [a] -> Set a
closure' Set a
interior [a]
xs
        | Bool
otherwise = Set a -> [a] -> Set a
closure' (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
x Set a
interior) ([a -> a
f a
x | a -> a
f <- [a -> a]
fs] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs)
    closure' interior :: Set a
interior [] = Set a
interior

closure :: [a] -> [a -> a] -> [a]
closure xs :: [a]
xs fs :: [a -> a]
fs = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a -> a] -> Set a
forall a. Ord a => [a] -> [a -> a] -> Set a
closureS [a]
xs [a -> a]
fs

orbit :: (t -> t -> t) -> t -> [t] -> [t]
orbit action :: t -> t -> t
action x :: t
x gs :: [t]
gs = [t] -> [t -> t] -> [t]
forall a. Ord a => [a] -> [a -> a] -> [a]
closure [t
x] [ (t -> t -> t
`action` t
g) | t
g <- [t]
gs]

-- |x .^^ gs returns the orbit of the point or vertex x under the action of the gs

(.^^) :: (Ord a) => a -> [Permutation a] -> [a]
x :: a
x .^^ :: a -> [Permutation a] -> [a]
.^^ gs :: [Permutation a]
gs = (a -> Permutation a -> a) -> a -> [Permutation a] -> [a]
forall t t. Ord t => (t -> t -> t) -> t -> [t] -> [t]
orbit a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
(.^) a
x [Permutation a]
gs

orbitP :: [Permutation t] -> t -> [t]
orbitP gs :: [Permutation t]
gs x :: t
x = (t -> Permutation t -> t) -> t -> [Permutation t] -> [t]
forall t t. Ord t => (t -> t -> t) -> t -> [t] -> [t]
orbit t -> Permutation t -> t
forall a. Ord a => a -> Permutation a -> a
(.^) t
x [Permutation t]
gs
orbitV :: [Permutation t] -> t -> [t]
orbitV gs :: [Permutation t]
gs x :: t
x = (t -> Permutation t -> t) -> t -> [Permutation t] -> [t]
forall t t. Ord t => (t -> t -> t) -> t -> [t] -> [t]
orbit t -> Permutation t -> t
forall a. Ord a => a -> Permutation a -> a
(.^) t
x [Permutation t]
gs

-- |b -^^ gs returns the orbit of the block or edge b under the action of the gs

(-^^) :: (Ord a) => [a] -> [Permutation a] -> [[a]]
b :: [a]
b -^^ :: [a] -> [Permutation a] -> [[a]]
-^^ gs :: [Permutation a]
gs = ([a] -> Permutation a -> [a]) -> [a] -> [Permutation a] -> [[a]]
forall t t. Ord t => (t -> t -> t) -> t -> [t] -> [t]
orbit [a] -> Permutation a -> [a]
forall a. Ord a => [a] -> Permutation a -> [a]
(-^) [a]
b [Permutation a]
gs

orbitB :: [Permutation a] -> [a] -> [[a]]
orbitB gs :: [Permutation a]
gs b :: [a]
b = ([a] -> Permutation a -> [a]) -> [a] -> [Permutation a] -> [[a]]
forall t t. Ord t => (t -> t -> t) -> t -> [t] -> [t]
orbit [a] -> Permutation a -> [a]
forall a. Ord a => [a] -> Permutation a -> [a]
(-^) [a]
b [Permutation a]
gs
orbitE :: [Permutation a] -> [a] -> [[a]]
orbitE gs :: [Permutation a]
gs b :: [a]
b = ([a] -> Permutation a -> [a]) -> [a] -> [Permutation a] -> [[a]]
forall t t. Ord t => (t -> t -> t) -> t -> [t] -> [t]
orbit [a] -> Permutation a -> [a]
forall a. Ord a => [a] -> Permutation a -> [a]
(-^) [a]
b [Permutation a]
gs


action :: [t] -> (t -> t) -> Permutation t
action xs :: [t]
xs f :: t -> t
f = [(t, t)] -> Permutation t
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [(t
x, t -> t
f t
x) | t
x <- [t]
xs]


-- find all the orbits of a group

-- (as we typically work with transitive groups, this is more useful for studying induced actions)

-- (Note that of course this won't find orbits of points which are fixed by all elts of G)

orbits :: [Permutation a] -> [[a]]
orbits gs :: [Permutation a]
gs = let 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 in [a] -> [[a]]
orbits' [a]
xs
    where orbits' :: [a] -> [[a]]
orbits' [] = []
          orbits' (x :: a
x:xs :: [a]
xs) = let o :: [a]
o = a
x a -> [Permutation a] -> [a]
forall a. Ord a => a -> [Permutation a] -> [a]
.^^ [Permutation a]
gs in [a]
o [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
orbits' ([a]
xs [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
o)


-- GROUPS

-- Some standard sequences of groups, and constructions of new groups from old


-- |_C n returns generators for Cn, the cyclic group of order n

_C :: (Integral a) => a -> [Permutation a]
_C :: a -> [Permutation a]
_C n :: a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = [[[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
p [[1..a
n]]]

-- D2n, dihedral group of order 2n, symmetry group of n-gon

-- For example, _D 8 == _D2 4 == symmetry group of square

_D :: a -> [Permutation a]
_D n :: a
n | a
r a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = a -> [Permutation a]
forall a. Integral a => a -> [Permutation a]
_D2 a
q where (q :: a
q,r :: a
r) = a
n a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 2

_D2 :: a -> [Permutation a]
_D2 n :: a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= 3 = [Permutation a
a,Permutation a
b] where
    a :: Permutation a
a = [[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
p [[1..a
n]]                            -- rotation

    b :: Permutation a
b = [[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
p [[a
i,a
na -> a -> a
forall a. Num a => a -> a -> a
+1a -> a -> a
forall a. Num a => a -> a -> a
-a
i] | a
i <- [1..a
n a -> a -> a
forall a. Integral a => a -> a -> a
`div` 2]]   -- reflection

    -- b = fromPairs $ [(i,n+1-i) | i <- [1..n]] -- reflection


-- |_S n returns generators for Sn, the symmetric group on [1..n]

_S :: (Integral a) => a -> [Permutation a]
_S :: a -> [Permutation a]
_S n :: a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= 3 = [Permutation a
s,Permutation a
forall a. (Ord a, Num a) => Permutation a
t]
     | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = [Permutation a
forall a. (Ord a, Num a) => Permutation a
t]
     | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = []
    where s :: Permutation a
s = [[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
p [[1..a
n]]
          t :: Permutation a
t = [[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
p [[1,2]]

-- |_A n returns generators for An, the alternating group on [1..n]

_A :: (Integral a) => a -> [Permutation a]
_A :: a -> [Permutation a]
_A n :: a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 3 = [Permutation a
s,Permutation a
forall a. (Ord a, Num a) => Permutation a
t]
     | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 3 = [Permutation a
forall a. (Ord a, Num a) => Permutation a
t]
     | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = []
    where s :: Permutation a
s | a -> Bool
forall a. Integral a => a -> Bool
odd a
n  = [[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
p [[3..a
n]]
            | a -> Bool
forall a. Integral a => a -> Bool
even a
n = [[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
p [[1,2], [3..a
n]]
          t :: Permutation a
t = [[a]] -> Permutation a
forall a. Ord a => [[a]] -> Permutation a
p [[1,2,3]]


-- |Given generators for groups H and K, acting on sets A and B respectively,

-- return generators for the direct product H*K, acting on the disjoint union A+B (= Either A B)

dp :: (Ord a, Ord b) => [Permutation a] -> [Permutation b] -> [Permutation (Either a b)]
dp :: [Permutation a] -> [Permutation b] -> [Permutation (Either a b)]
dp hs :: [Permutation a]
hs ks :: [Permutation b]
ks =
    [Map (Either a b) (Either a b) -> Permutation (Either a b)
forall a. Map a a -> Permutation a
P (Map (Either a b) (Either a b) -> Permutation (Either a b))
-> Map (Either a b) (Either a b) -> Permutation (Either a b)
forall a b. (a -> b) -> a -> b
$ [(Either a b, Either a b)] -> Map (Either a b) (Either a b)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Either a b, Either a b)] -> Map (Either a b) (Either a b))
-> [(Either a b, Either a b)] -> Map (Either a b) (Either a b)
forall a b. (a -> b) -> a -> b
$ ((a, a) -> (Either a b, Either a b))
-> [(a, a)] -> [(Either a b, Either a b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: a
x,x' :: a
x') -> (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
x')) ([(a, a)] -> [(Either a b, Either a b)])
-> [(a, a)] -> [(Either a b, Either a b)]
forall a b. (a -> b) -> a -> b
$ Map a a -> [(a, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map a a
h' | P h' :: Map a a
h' <- [Permutation a]
hs] [Permutation (Either a b)]
-> [Permutation (Either a b)] -> [Permutation (Either a b)]
forall a. [a] -> [a] -> [a]
++
    [Map (Either a b) (Either a b) -> Permutation (Either a b)
forall a. Map a a -> Permutation a
P (Map (Either a b) (Either a b) -> Permutation (Either a b))
-> Map (Either a b) (Either a b) -> Permutation (Either a b)
forall a b. (a -> b) -> a -> b
$ [(Either a b, Either a b)] -> Map (Either a b) (Either a b)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Either a b, Either a b)] -> Map (Either a b) (Either a b))
-> [(Either a b, Either a b)] -> Map (Either a b) (Either a b)
forall a b. (a -> b) -> a -> b
$ ((b, b) -> (Either a b, Either a b))
-> [(b, b)] -> [(Either a b, Either a b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(y :: b
y,y' :: b
y') -> (b -> Either a b
forall a b. b -> Either a b
Right b
y,b -> Either a b
forall a b. b -> Either a b
Right b
y')) ([(b, b)] -> [(Either a b, Either a b)])
-> [(b, b)] -> [(Either a b, Either a b)]
forall a b. (a -> b) -> a -> b
$ Map b b -> [(b, b)]
forall k a. Map k a -> [(k, a)]
M.toList Map b b
k' | P k' :: Map b b
k' <- [Permutation b]
ks]

-- Wreath product of groups

-- Given generators for H and K, acting on sets X and Y respectively,

-- return generators for H wr K, acting on X*Y (== (X,Y))

-- (Cameron, Combinatorics, p229-230; Cameron, Permutation Groups, p11-12)

wr :: [Permutation a] -> [Permutation a] -> [Permutation (a, a)]
wr hs :: [Permutation a]
hs ks :: [Permutation a]
ks =
    let _X :: [a]
_X = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ (Set a -> Set a -> Set a) -> Set a -> [Set a] -> Set a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union Set a
forall a. Set a
S.empty [Map a a -> Set a
forall k a. Map k a -> Set k
M.keysSet Map a a
h' | P h' :: Map a a
h' <- [Permutation a]
hs] -- set on which H acts

        _Y :: [a]
_Y = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ (Set a -> Set a -> Set a) -> Set a -> [Set a] -> Set a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union Set a
forall a. Set a
S.empty [Map a a -> Set a
forall k a. Map k a -> Set k
M.keysSet Map a a
k' | P k' :: Map a a
k' <- [Permutation a]
ks] -- set on which K acts

        -- Then the wreath product acts on cartesian product X * Y,

        -- regarded as a fibre bundle over Y of isomorphic copies of X

        _B :: [Permutation (a, a)]
_B = [Map (a, a) (a, a) -> Permutation (a, a)
forall a. Map a a -> Permutation a
P (Map (a, a) (a, a) -> Permutation (a, a))
-> Map (a, a) (a, a) -> Permutation (a, a)
forall a b. (a -> b) -> a -> b
$ [((a, a), (a, a))] -> Map (a, a) (a, a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((a, a), (a, a))] -> Map (a, a) (a, a))
-> [((a, a), (a, a))] -> Map (a, a) (a, a)
forall a b. (a -> b) -> a -> b
$ ((a, a) -> ((a, a), (a, a))) -> [(a, a)] -> [((a, a), (a, a))]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: a
x,x' :: a
x') -> ((a
x,a
y),(a
x',a
y))) ([(a, a)] -> [((a, a), (a, a))]) -> [(a, a)] -> [((a, a), (a, a))]
forall a b. (a -> b) -> a -> b
$ Map a a -> [(a, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map a a
h' | P h' :: Map a a
h' <- [Permutation a]
hs, a
y <- [a]
_Y]
        -- bottom group B applies the action of H within each fibre

        _T :: [Permutation (a, a)]
_T = [Map (a, a) (a, a) -> Permutation (a, a)
forall a. Map a a -> Permutation a
P (Map (a, a) (a, a) -> Permutation (a, a))
-> Map (a, a) (a, a) -> Permutation (a, a)
forall a b. (a -> b) -> a -> b
$ [((a, a), (a, a))] -> Map (a, a) (a, a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((a
x,a
y),(a
x,a
y')) | a
x <- [a]
_X, (y :: a
y,y' :: a
y') <- Map a a -> [(a, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map a a
k'] | P k' :: Map a a
k' <- [Permutation a]
ks]
        -- top group T uses the action of K to permute the fibres

    in [Permutation (a, a)]
_B [Permutation (a, a)]
-> [Permutation (a, a)] -> [Permutation (a, a)]
forall a. [a] -> [a] -> [a]
++ [Permutation (a, a)]
_T -- semi-direct product of B and T

-- !! Why using M.keysSet rather than supp?


-- embed group elts into Sn - ie, convert so that the set acted on is [1..n]

toSn :: [Permutation a] -> [Permutation a]
toSn gs :: [Permutation a]
gs = [Permutation a -> Permutation a
forall a. (Ord a, Num a, Enum a) => Permutation a -> Permutation a
toSn' Permutation a
g | Permutation a
g <- [Permutation a]
gs] where
    _X :: [a]
_X = [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ ([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   -- the set on which G acts

    mapping :: Map a a
mapping = [(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] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
_X [1..] -- the mapping from _X to [1..n]

    toSn' :: Permutation a -> Permutation a
toSn' g :: Permutation a
g = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs' ([(a, a)] -> Permutation a) -> [(a, a)] -> Permutation a
forall a b. (a -> b) -> a -> b
$ ((a, a) -> (a, a)) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: a
x,x' :: a
x') -> (Map a a
forall a. (Num a, Enum a) => Map a a
mapping Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! a
x, Map a a
forall a. (Num a, Enum a) => Map a a
mapping Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! a
x')) ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ Permutation a -> [(a, a)]
forall a. Permutation a -> [(a, a)]
toPairs Permutation a
g

-- Given a permutation over lists of small positive integers, such as [1,2,3],

-- return a permutation over the integers obtained by interpreting the lists as digits.

-- For example, [1,2,3] -> 123.

fromDigits :: Permutation [p] -> Permutation p
fromDigits g :: Permutation [p]
g = [(p, p)] -> Permutation p
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [([p] -> p
forall p. Num p => [p] -> p
fromDigits' [p]
x, [p] -> p
forall p. Num p => [p] -> p
fromDigits' [p]
y) | (x :: [p]
x,y :: [p]
y) <- Permutation [p] -> [([p], [p])]
forall a. Permutation a -> [(a, a)]
toPairs Permutation [p]
g]

fromDigits' :: [p] -> p
fromDigits' xs :: [p]
xs = [p] -> p
forall p. Num p => [p] -> p
f ([p] -> [p]
forall a. [a] -> [a]
reverse [p]
xs) where
    f :: [p] -> p
f (x :: p
x:xs :: [p]
xs) = p
x p -> p -> p
forall a. Num a => a -> a -> a
+ 10 p -> p -> p
forall a. Num a => a -> a -> a
* [p] -> p
f [p]
xs
    f [] = 0

-- Given a permutation over lists of 0s and 1s,

-- return the permutation obtained by interpreting these as binary digits.

-- For example, [1,1,0] -> 6.

fromBinary :: Permutation [p] -> Permutation p
fromBinary g :: Permutation [p]
g = [(p, p)] -> Permutation p
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [([p] -> p
forall p. Num p => [p] -> p
fromBinary' [p]
x, [p] -> p
forall p. Num p => [p] -> p
fromBinary' [p]
y) | (x :: [p]
x,y :: [p]
y) <- Permutation [p] -> [([p], [p])]
forall a. Permutation a -> [(a, a)]
toPairs Permutation [p]
g]

fromBinary' :: [p] -> p
fromBinary' xs :: [p]
xs = [p] -> p
forall p. Num p => [p] -> p
f ([p] -> [p]
forall a. [a] -> [a]
reverse [p]
xs) where
    f :: [p] -> p
f (x :: p
x:xs :: [p]
xs) = p
x p -> p -> p
forall a. Num a => a -> a -> a
+ 2 p -> p -> p
forall a. Num a => a -> a -> a
* [p] -> p
f [p]
xs
    f [] = 0




-- INVESTIGATING GROUPS

-- Functions to investigate groups in various ways

-- Most of these functions will only be efficient for small groups (say |G| < 10000)

-- For larger groups we will need to use Schreier-Sims and associated algorithms


-- |Given generators for a group, return a (sorted) list of all elements of the group.

-- Implemented using a naive closure algorithm, so only suitable for small groups (|G| < 10000)

elts :: (Num a, Ord a) => [a] -> [a]
elts :: [a] -> [a]
elts gs :: [a]
gs = [a] -> [a -> a] -> [a]
forall a. Ord a => [a] -> [a -> a] -> [a]
closure [1] [ (a -> a -> a
forall a. Num a => a -> a -> a
*a
g) | a
g <- [a]
gs]

eltsS :: [a] -> Set a
eltsS gs :: [a]
gs = [a] -> [a -> a] -> Set a
forall a. Ord a => [a] -> [a -> a] -> Set a
closureS [1] [ (a -> a -> a
forall a. Num a => a -> a -> a
*a
g) | a
g <- [a]
gs]

-- |Given generators for a group, return the order of the group (the number of elements).

-- Implemented using a naive closure algorithm, so only suitable for small groups (|G| < 10000)

order :: (Num a, Ord a) => [a] -> Int
order :: [a] -> Int
order gs :: [a]
gs = Set a -> Int
forall a. Set a -> Int
S.size (Set a -> Int) -> Set a -> Int
forall a b. (a -> b) -> a -> b
$ [a] -> Set a
forall a. (Ord a, Num a) => [a] -> Set a
eltsS [a]
gs -- length $ elts gs


isMember :: [a] -> a -> Bool
isMember gs :: [a]
gs h :: a
h = a
h a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` [a] -> Set a
forall a. (Ord a, Num a) => [a] -> Set a
eltsS [a]
gs -- h `elem` elts gs



-- TRANSVERSAL GENERATING SETS

-- The functions graphAuts2 and graphAuts3 return generating sets consisting of successive transversals

-- In this case, we don't need to run Schreier-Sims to list elements or calculate order


minsupp :: Permutation c -> c
minsupp = [c] -> c
forall a. [a] -> a
head ([c] -> c) -> (Permutation c -> [c]) -> Permutation c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation c -> [c]
forall a. Permutation a -> [a]
supp

-- calculate the order of the group, given a "transversal generating set"

orderTGS :: [Permutation c] -> a
orderTGS tgs :: [Permutation c]
tgs =
    let transversals :: [[Permutation c]]
transversals = ([Permutation c] -> [Permutation c])
-> [[Permutation c]] -> [[Permutation c]]
forall a b. (a -> b) -> [a] -> [b]
map (1Permutation c -> [Permutation c] -> [Permutation c]
forall a. a -> [a] -> [a]
:) ([[Permutation c]] -> [[Permutation c]])
-> [[Permutation c]] -> [[Permutation c]]
forall a b. (a -> b) -> a -> b
$ (Permutation c -> Permutation c -> Bool)
-> [Permutation c] -> [[Permutation c]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\g :: Permutation c
g h :: Permutation c
h -> Permutation c -> c
forall c. Permutation c -> c
minsupp Permutation c
g c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== Permutation c -> c
forall c. Permutation c -> c
minsupp Permutation c
h) [Permutation c]
tgs
    in [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ ([Permutation c] -> a) -> [[Permutation c]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [Permutation c] -> a
forall i a. Num i => [a] -> i
L.genericLength [[Permutation c]]
transversals

-- list the elts of the group, given a "transversal generating set"

eltsTGS :: [Permutation c] -> [Permutation c]
eltsTGS tgs :: [Permutation c]
tgs =
    let transversals :: [[Permutation c]]
transversals = ([Permutation c] -> [Permutation c])
-> [[Permutation c]] -> [[Permutation c]]
forall a b. (a -> b) -> [a] -> [b]
map (1Permutation c -> [Permutation c] -> [Permutation c]
forall a. a -> [a] -> [a]
:) ([[Permutation c]] -> [[Permutation c]])
-> [[Permutation c]] -> [[Permutation c]]
forall a b. (a -> b) -> a -> b
$ (Permutation c -> Permutation c -> Bool)
-> [Permutation c] -> [[Permutation c]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\g :: Permutation c
g h :: Permutation c
h -> Permutation c -> c
forall c. Permutation c -> c
minsupp Permutation c
g c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== Permutation c -> c
forall c. Permutation c -> c
minsupp Permutation c
h) [Permutation c]
tgs
    in ([Permutation c] -> Permutation c)
-> [[Permutation c]] -> [Permutation c]
forall a b. (a -> b) -> [a] -> [b]
map [Permutation c] -> Permutation c
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([[Permutation c]] -> [Permutation c])
-> [[Permutation c]] -> [Permutation c]
forall a b. (a -> b) -> a -> b
$ [[Permutation c]] -> [[Permutation c]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[Permutation c]]
transversals

-- recover a transversal generating set from a strong generating set

-- A strong generating set is a generating set gs such that <gs intersect si> = si

-- ie, its intersection with each successive stabiliser in the chain generates the stabiliser

tgsFromSgs :: [Permutation a] -> [Permutation a]
tgsFromSgs sgs :: [Permutation a]
sgs = (a -> [Permutation a]) -> [a] -> [Permutation a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [Permutation a]
transversal [a]
bs where
    bs :: [a]
bs = [a] -> [a]
forall a. Ord a => [a] -> [a]
toListSet ([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 c. Permutation c -> c
minsupp [Permutation a]
sgs
    transversal :: a -> [Permutation a]
transversal b :: a
b = a -> [Permutation a] -> [Permutation a]
forall k. Ord k => k -> [Permutation k] -> [Permutation k]
closure a
b ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter ( (a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=) (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]
sgs
    closure :: k -> [Permutation k] -> [Permutation k]
closure b :: k
b gs :: [Permutation k]
gs = Map k (Permutation k) -> Map k (Permutation k) -> [Permutation k]
closure' Map k (Permutation k)
forall k a. Map k a
M.empty ([(k, Permutation k)] -> Map k (Permutation k)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(k
b, 1)]) where
        closure' :: Map k (Permutation k) -> Map k (Permutation k) -> [Permutation k]
closure' interior :: Map k (Permutation k)
interior boundary :: Map k (Permutation k)
boundary
            | Map k (Permutation k) -> Bool
forall k a. Map k a -> Bool
M.null Map k (Permutation k)
boundary = (Permutation k -> Bool) -> [Permutation k] -> [Permutation k]
forall a. (a -> Bool) -> [a] -> [a]
filter (Permutation k -> Permutation k -> Bool
forall a. Eq a => a -> a -> Bool
/=1) ([Permutation k] -> [Permutation k])
-> [Permutation k] -> [Permutation k]
forall a b. (a -> b) -> a -> b
$ Map k (Permutation k) -> [Permutation k]
forall k a. Map k a -> [a]
M.elems Map k (Permutation k)
interior
            | Bool
otherwise =
                let interior' :: Map k (Permutation k)
interior' = Map k (Permutation k)
-> Map k (Permutation k) -> Map k (Permutation k)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map k (Permutation k)
interior Map k (Permutation k)
boundary
                    boundary' :: Map k (Permutation k)
boundary' = [(k, Permutation k)] -> Map k (Permutation k)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(k
x k -> Permutation k -> k
forall a. Ord a => a -> Permutation a -> a
.^ Permutation k
g, Permutation k
hPermutation k -> Permutation k -> Permutation k
forall a. Num a => a -> a -> a
*Permutation k
g) | (x :: k
x,h :: Permutation k
h) <- Map k (Permutation k) -> [(k, Permutation k)]
forall k a. Map k a -> [(k, a)]
M.toList Map k (Permutation k)
boundary, Permutation k
g <- [Permutation k]
gs] Map k (Permutation k)
-> Map k (Permutation k) -> Map k (Permutation k)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.\\ Map k (Permutation k)
interior'
                in Map k (Permutation k) -> Map k (Permutation k) -> [Permutation k]
closure' Map k (Permutation k)
interior' Map k (Permutation k)
boundary'
-- For example, sgs (_A 5) == [[[1,2,3]],[[2,4,5]],[[3,4,5]]]

-- So we need all three to generate the first transversal, then the last two to generate the second transversal, etc


-- |Given a strong generating set, return the order of the group it generates.

-- Note that the SGS is assumed to be relative to the natural order of the points on which the group acts.

orderSGS :: (Ord a) => [Permutation a] -> Integer
orderSGS :: [Permutation a] -> Integer
orderSGS sgs :: [Permutation a]
sgs = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (a -> Integer) -> [a] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map ([a] -> Integer
forall i a. Num i => [a] -> i
L.genericLength ([a] -> Integer) -> (a -> [a]) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
fundamentalOrbit) [a]
bs where
    bs :: [a]
bs = [a] -> [a]
forall a. Ord a => [a] -> [a]
toListSet ([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 c. Permutation c -> c
minsupp [Permutation a]
sgs
    fundamentalOrbit :: a -> [a]
fundamentalOrbit b :: a
b = a
b a -> [Permutation a] -> [a]
forall a. Ord a => a -> [Permutation a] -> [a]
.^^ (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter ( (a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=) (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]
sgs

-- !! Needs more testing

-- |Given a base and strong generating set, return the order of the group it generates.

orderBSGS :: (Ord a) => ([a],[Permutation a]) -> Integer
orderBSGS :: ([a], [Permutation a]) -> Integer
orderBSGS (bs :: [a]
bs,sgs :: [Permutation a]
sgs) = Integer -> [a] -> [Permutation a] -> Integer
forall t a. (Num t, Ord a) => t -> [a] -> [Permutation a] -> t
go 1 [a]
bs [Permutation a]
sgs where
    go :: t -> [a] -> [Permutation a] -> t
go n :: t
n [] _ = t
n
    go n :: t
n (b :: a
b:bs :: [a]
bs) gs :: [Permutation a]
gs = t -> [a] -> [Permutation a] -> t
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
* [a] -> t
forall i a. Num i => [a] -> i
L.genericLength (a
b a -> [Permutation a] -> [a]
forall a. Ord a => a -> [Permutation a] -> [a]
.^^ [Permutation a]
gs)) [a]
bs ((Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\g :: Permutation a
g -> a
b a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b) [Permutation a]
gs)


-- MORE INVESTIGATIONS


-- given the elts of a group, find generators

gens :: [a] -> [a]
gens hs :: [a]
hs = [a] -> Set a -> [a] -> [a]
forall a. (Ord a, Num a) => [a] -> Set a -> [a] -> [a]
gens' [] (a -> Set a
forall a. a -> Set a
S.singleton 1) [a]
hs where
    gens' :: [a] -> Set a -> [a] -> [a]
gens' gs :: [a]
gs eltsG :: Set a
eltsG (h :: a
h:hs :: [a]
hs) = if a
h a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
eltsG then [a] -> Set a -> [a] -> [a]
gens' [a]
gs Set a
eltsG [a]
hs else [a] -> Set a -> [a] -> [a]
gens' (a
ha -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
gs) ([a] -> Set a
forall a. (Ord a, Num a) => [a] -> Set a
eltsS ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ a
ha -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
gs) [a]
hs
    gens' gs :: [a]
gs _ [] = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
gs



-- conjClass gs h = orbit (~^) gs h


-- Conjugacy class - should only be used for small groups

h :: Permutation a
h ~^^ :: Permutation a -> [Permutation a] -> [Permutation a]
~^^ gs :: [Permutation a]
gs = [Permutation a] -> Permutation a -> [Permutation a]
forall a.
Ord a =>
[Permutation a] -> Permutation a -> [Permutation a]
conjClass [Permutation a]
gs Permutation a
h

conjClass :: [Permutation a] -> Permutation a -> [Permutation a]
conjClass gs :: [Permutation a]
gs h :: Permutation a
h = [Permutation a]
-> [Permutation a -> Permutation a] -> [Permutation a]
forall a. Ord a => [a] -> [a -> a] -> [a]
closure [Permutation a
h] [ (Permutation a -> Permutation a -> Permutation a
forall a. Ord a => Permutation a -> Permutation a -> Permutation a
~^ Permutation a
g) | Permutation a
g <- [Permutation a]
gs]
-- conjClass gs h = h ~^^ gs


-- |conjClassReps gs returns conjugacy class representatives and sizes for the group generated by gs.

-- This implementation is only suitable for use with small groups (|G| < 10000).

conjClassReps :: (Ord a, Show a) => [Permutation a] -> [(Permutation a, Int)]
conjClassReps :: [Permutation a] -> [(Permutation a, Int)]
conjClassReps gs :: [Permutation a]
gs = [Permutation a] -> [(Permutation a, Int)]
conjClassReps' ([Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
gs) where
    conjClassReps' :: [Permutation a] -> [(Permutation a, Int)]
conjClassReps' (h :: Permutation a
h:hs :: [Permutation a]
hs) =
        let cc :: [Permutation a]
cc = [Permutation a] -> Permutation a -> [Permutation a]
forall a.
Ord a =>
[Permutation a] -> Permutation a -> [Permutation a]
conjClass [Permutation a]
gs Permutation a
h in (Permutation a
h, [Permutation a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Permutation a]
cc) (Permutation a, Int)
-> [(Permutation a, Int)] -> [(Permutation a, Int)]
forall a. a -> [a] -> [a]
: [Permutation a] -> [(Permutation a, Int)]
conjClassReps' ([Permutation a]
hs [Permutation a] -> [Permutation a] -> [Permutation a]
forall a. Ord a => [a] -> [a] -> [a]
\\ [Permutation a]
cc)
    conjClassReps' [] = []
-- using the ListSet implementation of \\, since we know both lists are sorted


{-
-- This is just the orbits under conjugation. Can we generalise "orbits" to help us here?
conjClasses gs = conjClasses' (elts gs)
    where conjClasses' [] = []
          conjClasses' (h:hs) = let c = conjClass gs h in c : conjClasses' (hs L.\\ c)
-}


-- given list of generators, try to find a shorter list

reduceGens :: [a] -> [a]
reduceGens (1:gs :: [a]
gs) = [a] -> [a]
reduceGens [a]
gs
reduceGens (g :: a
g:gs :: [a]
gs) = ([a], Set a) -> [a] -> [a]
forall a. (Ord a, Num a) => ([a], Set a) -> [a] -> [a]
reduceGens' ([a
g], [a] -> Set a
forall a. (Ord a, Num a) => [a] -> Set a
eltsS [a
g]) [a]
gs where
    reduceGens' :: ([a], Set a) -> [a] -> [a]
reduceGens' (gs :: [a]
gs,eltsgs :: Set a
eltsgs) (h :: a
h:hs :: [a]
hs) =
        if a
h a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
eltsgs
        then ([a], Set a) -> [a] -> [a]
reduceGens' ([a]
gs,Set a
eltsgs) [a]
hs
        else ([a], Set a) -> [a] -> [a]
reduceGens' (a
ha -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
gs, [a] -> Set a
forall a. (Ord a, Num a) => [a] -> Set a
eltsS ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ a
ha -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
gs) [a]
hs
    reduceGens' (gs :: [a]
gs,_) [] = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
gs


-- SUBGROUPS


isSubgp :: t a -> [a] -> Bool
isSubgp hs :: t a
hs gs :: [a]
gs = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
gs') t a
hs
    where gs' :: Set a
gs' = [a] -> Set a
forall a. (Ord a, Num a) => [a] -> Set a
eltsS [a]
gs

-- The following is similar to the "cyclic extension" method - Holt p385

-- However, Holt only looks at normal cyclic extensions (ie, by an elt of prime order), and so only finds solvable subgps


-- |Return the subgroups of a group. Only suitable for use on small groups (eg < 100 elts)

subgps :: (Ord a, Show a) => [Permutation a] -> [[Permutation a]]
subgps :: [Permutation a] -> [[Permutation a]]
subgps gs :: [Permutation a]
gs = [] [Permutation a] -> [[Permutation a]] -> [[Permutation a]]
forall a. a -> [a] -> [a]
: Set [Permutation a]
-> [[Permutation a]] -> [[Permutation a]] -> [[Permutation a]]
subgps' Set [Permutation a]
forall a. Set a
S.empty [] ((Permutation a -> [Permutation a])
-> [Permutation a] -> [[Permutation a]]
forall a b. (a -> b) -> [a] -> [b]
map (Permutation a -> [Permutation a] -> [Permutation a]
forall a. a -> [a] -> [a]
:[]) [Permutation a]
hs) where
    hs :: [Permutation a]
hs = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter Permutation a -> Bool
forall a. Ord a => Permutation a -> Bool
isMinimal ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
gs
    subgps' :: Set [Permutation a]
-> [[Permutation a]] -> [[Permutation a]] -> [[Permutation a]]
subgps' found :: Set [Permutation a]
found ls :: [[Permutation a]]
ls (r :: [Permutation a]
r:rs :: [[Permutation a]]
rs) =
        let ks :: [Permutation a]
ks = [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
r in
        if [Permutation a]
ks [Permutation a] -> Set [Permutation a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [Permutation a]
found
        then Set [Permutation a]
-> [[Permutation a]] -> [[Permutation a]] -> [[Permutation a]]
subgps' Set [Permutation a]
found [[Permutation a]]
ls [[Permutation a]]
rs
        else [Permutation a]
r [Permutation a] -> [[Permutation a]] -> [[Permutation a]]
forall a. a -> [a] -> [a]
: Set [Permutation a]
-> [[Permutation a]] -> [[Permutation a]] -> [[Permutation a]]
subgps' ([Permutation a] -> Set [Permutation a] -> Set [Permutation a]
forall a. Ord a => a -> Set a -> Set a
S.insert [Permutation a]
ks Set [Permutation a]
found) ([Permutation a]
r[Permutation a] -> [[Permutation a]] -> [[Permutation a]]
forall a. a -> [a] -> [a]
:[[Permutation a]]
ls) [[Permutation a]]
rs
    subgps' found :: Set [Permutation a]
found [] [] = []
    subgps' found :: Set [Permutation a]
found ls :: [[Permutation a]]
ls [] = Set [Permutation a]
-> [[Permutation a]] -> [[Permutation a]] -> [[Permutation a]]
subgps' Set [Permutation a]
found [] [[Permutation a]
l [Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++ [Permutation a
h] | [Permutation a]
l <- [[Permutation a]] -> [[Permutation a]]
forall a. [a] -> [a]
reverse [[Permutation a]]
ls, Permutation a
h <- [Permutation a]
hs, [Permutation a] -> Permutation a
forall a. [a] -> a
last [Permutation a]
l Permutation a -> Permutation a -> Bool
forall a. Ord a => a -> a -> Bool
< Permutation a
h]

-- g is the minimal elt in the cyclic subgp it generates

isMinimal :: Permutation a -> Bool
isMinimal 1 = Bool
False
isMinimal g :: Permutation a
g = (Permutation a -> Bool) -> [Permutation a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Permutation a
g Permutation a -> Permutation a -> Bool
forall a. Ord a => a -> a -> Bool
<=) [Permutation a]
primitives -- g == minimum primitives

    where powers :: [Permutation a]
powers = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (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] -> [Permutation a]
forall a. [a] -> [a]
tail ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (Permutation a -> Permutation a)
-> Permutation a -> [Permutation a]
forall a. (a -> a) -> a -> [a]
iterate (Permutation a -> Permutation a -> Permutation a
forall a. Num a => a -> a -> a
*Permutation a
g) 1
          n :: Int
n = Permutation a -> Int
forall a. Ord a => Permutation a -> Int
orderElt Permutation a
g -- == length powers + 1

          primitives :: [Permutation a]
primitives = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\h :: Permutation a
h -> Permutation a -> Int
forall a. Ord a => Permutation a -> Int
orderElt Permutation a
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) [Permutation a]
powers


-- centralizer of a subgroup or a set of elts

-- the centralizer of H in G is the set of elts of G which commute with all elts of H

centralizer :: [a] -> t a -> [a]
centralizer gs :: [a]
gs hs :: t a
hs = [a
k | a
k <- [a] -> [a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [a]
gs, (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\h :: a
h -> a
ha -> a -> a
forall a. Num a => a -> a -> a
*a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ka -> a -> a
forall a. Num a => a -> a -> a
*a
h) t a
hs]

-- the centre of G is the set of elts of G which commute with all other elts

centre :: [a] -> [a]
centre gs :: [a]
gs = [a] -> [a] -> [a]
forall a (t :: * -> *).
(Num a, Ord a, Foldable t) =>
[a] -> t a -> [a]
centralizer [a]
gs [a]
gs

-- normaliser of a subgroup

-- the normaliser of H in G is {g <- G | g^-1Hg == H}

-- it is a subgroup of G, and H is a normal subgroup of it: H <|= N_G(H) <= G

normalizer :: [Permutation a] -> [Permutation a] -> [Permutation a]
normalizer gs :: [Permutation a]
gs hs :: [Permutation a]
hs = [Permutation a
g | Permutation a
g <- [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
gs, (Permutation a -> Bool) -> [Permutation a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\h :: Permutation a
h -> Permutation a
hPermutation a -> Permutation a -> Permutation a
forall a. Ord a => Permutation a -> Permutation a -> Permutation a
~^Permutation a
g Permutation a -> [Permutation a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
hs) [Permutation a]
hs]

-- stabilizer of a point

stabilizer :: [Permutation a] -> a -> [Permutation a]
stabilizer gs :: [Permutation a]
gs x :: a
x = [Permutation a
g | Permutation a
g <- [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
gs, a
x a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x]

-- pointwise stabiliser of a set

ptStab :: [Permutation a] -> [a] -> [Permutation a]
ptStab gs :: [Permutation a]
gs xs :: [a]
xs = [Permutation a
g | Permutation a
g <- [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
gs, [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [a
x a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x | a
x <- [a]
xs] ]

-- setwise stabiliser of a set

setStab :: [Permutation a] -> [a] -> [Permutation a]
setStab gs :: [Permutation a]
gs xs :: [a]
xs = [Permutation a
g | Permutation a
g <- [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
gs, [a]
xs [a] -> Permutation a -> [a]
forall a. Ord a => [a] -> Permutation a -> [a]
-^ Permutation a
g [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
xs]

-- normal closure of H in G

normalClosure :: [Permutation a] -> [Permutation a] -> [Permutation a]
normalClosure gs :: [Permutation a]
gs hs :: [Permutation a]
hs = [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
reduceGens ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ [Permutation a]
hs [Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++ [Permutation a
h Permutation a -> Permutation a -> Permutation a
forall a. Ord a => Permutation a -> Permutation a -> Permutation a
~^ Permutation a
g | Permutation a
h <- [Permutation a]
hs, Permutation a
g <- [Permutation a]
gs [Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++ (Permutation a -> Permutation a)
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map Permutation a -> Permutation a
forall a. HasInverses a => a -> a
inverse [Permutation a]
gs]

-- commutator gp of H and K

commutatorGp :: [Permutation a] -> [Permutation a] -> [Permutation a]
commutatorGp hs :: [Permutation a]
hs ks :: [Permutation a]
ks = [Permutation a] -> [Permutation a] -> [Permutation a]
forall a.
Ord a =>
[Permutation a] -> [Permutation a] -> [Permutation a]
normalClosure ([Permutation a]
hsks) [Permutation a
hPermutation a -> Integer -> Permutation a
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1 Permutation a -> Permutation a -> Permutation a
forall a. Num a => a -> a -> a
* Permutation a
kPermutation a -> Integer -> Permutation a
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1 Permutation a -> Permutation a -> Permutation a
forall a. Num a => a -> a -> a
* Permutation a
h Permutation a -> Permutation a -> Permutation a
forall a. Num a => a -> a -> a
* Permutation a
k | Permutation a
h <- [Permutation a]
hs', Permutation a
k <- [Permutation a]
ks']
    where hs' :: [Permutation a]
hs' = [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
reduceGens [Permutation a]
hs
          ks' :: [Permutation a]
ks' = [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
reduceGens [Permutation a]
ks
          hsks :: [Permutation a]
hsks = [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
reduceGens ([Permutation a]
hs' [Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++ [Permutation a]
ks')
          -- no point processing more potential generators than we have to


-- derived subgroup

derivedSubgp :: [Permutation a] -> [Permutation a]
derivedSubgp gs :: [Permutation a]
gs = [Permutation a] -> [Permutation a] -> [Permutation a]
forall a.
Ord a =>
[Permutation a] -> [Permutation a] -> [Permutation a]
commutatorGp [Permutation a]
gs [Permutation a]
gs


-- ACTION ON COSETS, QUOTIENT GROUPS


xs :: [b]
xs -*- :: [b] -> [b] -> [b]
-*- ys :: [b]
ys = [b] -> [b]
forall a. Ord a => [a] -> [a]
toListSet [b
xb -> b -> b
forall a. Num a => a -> a -> a
*b
y | b
x <- [b]
xs, b
y <- [b]
ys]

xs :: [a]
xs -* :: [a] -> a -> [a]
-*  y :: a
y  = [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
xa -> a -> a
forall a. Num a => a -> a -> a
*a
y | a
x <- [a]
xs] -- == xs -*- [y]

x :: a
x   *- :: a -> [a] -> [a]
*- ys :: [a]
ys = [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
xa -> a -> a
forall a. Num a => a -> a -> a
*a
y | a
y <- [a]
ys] -- == [x] -*- ys


-- |isNormal gs ks returns True if \<ks\> is normal in \<gs\>.

-- Note, it is caller's responsibility to ensure that \<ks\> is a subgroup of \<gs\> (ie that each k is in \<gs\>).

isNormal :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> Bool
isNormal :: [Permutation a] -> [Permutation a] -> Bool
isNormal gs :: [Permutation a]
gs ks :: [Permutation a]
ks = ([Permutation a] -> Bool) -> [[Permutation a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Permutation a] -> [Permutation a] -> Bool
forall a. Eq a => a -> a -> Bool
== [Permutation a]
ks') [ (Permutation a
gPermutation a -> Integer -> Permutation a
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1) Permutation a -> [Permutation a] -> [Permutation a]
forall a. (Ord a, Num a) => a -> [a] -> [a]
*- [Permutation a]
ks' [Permutation a] -> Permutation a -> [Permutation a]
forall a. (Ord a, Num a) => [a] -> a -> [a]
-* Permutation a
g | Permutation a
g <- [Permutation a]
gs]
    where ks' :: [Permutation a]
ks' = [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
ks

-- |Return the normal subgroups of a group. Only suitable for use on small groups (eg < 100 elts)

normalSubgps :: (Ord a, Show a) => [Permutation a] -> [[Permutation a]]
normalSubgps :: [Permutation a] -> [[Permutation a]]
normalSubgps 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.
(Ord a, Show a) =>
[Permutation a] -> [Permutation a] -> Bool
isNormal [Permutation a]
gs) ([Permutation a] -> [[Permutation a]]
forall a. (Ord a, Show a) => [Permutation a] -> [[Permutation a]]
subgps [Permutation a]
gs)

isSimple :: [Permutation a] -> Bool
isSimple gs :: [Permutation a]
gs = [[Permutation a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Permutation a] -> [[Permutation a]]
forall a. (Ord a, Show a) => [Permutation a] -> [[Permutation a]]
normalSubgps [Permutation a]
gs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2

-- Note: caller must ensure that hs is a subgp of gs

cosets :: [a] -> [a] -> [[a]]
cosets gs :: [a]
gs hs :: [a]
hs = ([a] -> a -> [a]) -> [a] -> [a] -> [[a]]
forall t t. Ord t => (t -> t -> t) -> t -> [t] -> [t]
orbit [a] -> a -> [a]
forall a. (Ord a, Num a) => [a] -> a -> [a]
(-*) [a]
hs' [a]
gs
    where hs' :: [a]
hs' = [a] -> [a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [a]
hs

-- |quotientGp gs ks returns \<gs\> / \<ks\>

quotientGp :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> [Permutation Int]
quotientGp :: [Permutation a] -> [Permutation a] -> [Permutation Int]
quotientGp gs :: [Permutation a]
gs ks :: [Permutation a]
ks
    | [Permutation a]
ks [Permutation a] -> [Permutation a] -> Bool
forall a.
(Ord a, Show a) =>
[Permutation a] -> [Permutation a] -> Bool
`isNormal` [Permutation a]
gs = [Permutation Int] -> [Permutation Int]
forall a. (Ord a, Num a) => [a] -> [a]
gens ([Permutation Int] -> [Permutation Int])
-> [Permutation Int] -> [Permutation Int]
forall a b. (a -> b) -> a -> b
$ [Permutation [Permutation a]] -> [Permutation Int]
forall a a.
(Ord a, Num a, Enum a, Ord a) =>
[Permutation a] -> [Permutation a]
toSn [[[Permutation a]]
-> ([Permutation a] -> [Permutation a])
-> Permutation [Permutation a]
forall t. Ord t => [t] -> (t -> t) -> Permutation t
action [[Permutation a]]
cosetsK ([Permutation a] -> Permutation a -> [Permutation a]
forall a. (Ord a, Num a) => [a] -> a -> [a]
-* Permutation a
g) | Permutation a
g <- [Permutation a]
gs]
    | Bool
otherwise = [Char] -> [Permutation Int]
forall a. HasCallStack => [Char] -> a
error "quotientGp: not well defined unless ks normal in gs"
    where cosetsK :: [[Permutation a]]
cosetsK = [Permutation a] -> [Permutation a] -> [[Permutation a]]
forall a. (Num a, Ord a) => [a] -> [a] -> [[a]]
cosets [Permutation a]
gs [Permutation a]
ks

-- |Synonym for quotientGp

(//) :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> [Permutation Int]
gs :: [Permutation a]
gs // :: [Permutation a] -> [Permutation a] -> [Permutation Int]
// ks :: [Permutation a]
ks = [Permutation a] -> [Permutation a] -> [Permutation Int]
forall a.
(Ord a, Show a) =>
[Permutation a] -> [Permutation a] -> [Permutation Int]
quotientGp [Permutation a]
gs [Permutation a]
ks


-- action of group element on a subset by conjugation

xs :: [Permutation a]
xs ~~^ :: [Permutation a] -> Permutation a -> [Permutation a]
~~^ g :: Permutation a
g = [Permutation a] -> [Permutation a]
forall a. Ord a => [a] -> [a]
L.sort [Permutation a
x Permutation a -> Permutation a -> Permutation a
forall a. Ord a => Permutation a -> Permutation a -> Permutation a
~^ Permutation a
g | Permutation a
x <- [Permutation a]
xs]

conjugateSubgps :: [Permutation a] -> [Permutation a] -> [[Permutation a]]
conjugateSubgps gs :: [Permutation a]
gs hs :: [Permutation a]
hs = ([Permutation a] -> Permutation a -> [Permutation a])
-> [Permutation a] -> [Permutation a] -> [[Permutation a]]
forall t t. Ord t => (t -> t -> t) -> t -> [t] -> [t]
orbit [Permutation a] -> Permutation a -> [Permutation a]
forall a.
Ord a =>
[Permutation a] -> Permutation a -> [Permutation a]
(~~^) [Permutation a]
hs' [Permutation a]
gs
    where hs' :: [Permutation a]
hs' = [Permutation a] -> [Permutation a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [Permutation a]
hs
-- not necessarily transitive on isomorphic subgps - eg a gp with an outer aut


subgpAction :: [Permutation a] -> [Permutation a] -> [Permutation a]
subgpAction gs :: [Permutation a]
gs hs :: [Permutation a]
hs =
    let conjugatesH :: [[Permutation a]]
conjugatesH = [Permutation a] -> [Permutation a] -> [[Permutation a]]
forall a.
Ord a =>
[Permutation a] -> [Permutation a] -> [[Permutation a]]
conjugateSubgps [Permutation a]
gs [Permutation a]
hs
    in [Permutation [Permutation a]] -> [Permutation a]
forall a a.
(Ord a, Num a, Enum a, Ord a) =>
[Permutation a] -> [Permutation a]
toSn [[[Permutation a]]
-> ([Permutation a] -> [Permutation a])
-> Permutation [Permutation a]
forall t. Ord t => [t] -> (t -> t) -> Permutation t
action [[Permutation a]]
conjugatesH ([Permutation a] -> Permutation a -> [Permutation a]
forall a.
Ord a =>
[Permutation a] -> Permutation a -> [Permutation a]
~~^ Permutation a
g) | Permutation a
g <- [Permutation a]
gs]


-- in cube gp, the subgps all appear to correspond to stabilisers of subsets, or of blocks



-- right regular permutation representation

rrpr :: [a] -> a -> Permutation a
rrpr gs :: [a]
gs h :: a
h = [a] -> a -> Permutation a
forall a. (Ord a, Num a) => [a] -> a -> Permutation a
rrpr' ([a] -> [a]
forall a. (Num a, Ord a) => [a] -> [a]
elts [a]
gs) a
h

rrpr' :: [a] -> a -> Permutation a
rrpr' gs :: [a]
gs h :: a
h = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [(a
g, a
ga -> a -> a
forall a. Num a => a -> a -> a
*a
h) | a
g <- [a]
gs]

permutationMatrix :: [a] -> Permutation a -> [[a]]
permutationMatrix xs :: [a]
xs g :: Permutation a
g = [ [if a
x a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then 1 else 0 | a
y <- [a]
xs] | a
x <- [a]
xs ]