# Test for group isomorphism and construct automorphism groups

MMA has some support for group theory, allowing representation of any finite group as a subgroup of $S_n$. It does not seem to have a function for testing whether two finite groups are isomorphic. Is there a straightforward (and computationally reasonable) way,

1. To test whether two groups are isomorphic?

2. To find an explicit isomorphism between two groups?

3. To find all isomorphisms from a group to itself, i.e. construct the automorphism group?

Thanks.

EDIT: Here's an example of the problem.

(Local) In:= d8a = DihedralGroup

(Local) Out= DihedralGroup

(Local) In:= GroupGenerators[d8a]

(Local) Out= {Cycles[{{1, 4}, {2, 3}}], Cycles[{{1, 2, 3, 4}}]}

(Local) In:= d8b = PermutationGroup[GroupMultiplicationTable[d8a]]

(Local) Out= PermutationGroup[{{1, 2, 3, 4, 5, 6, 7, 8}, {2, 1, 4,
3, 6, 5, 8, 7}, {3, 7, 1, 5, 4, 8, 2, 6}, {4, 8, 2, 6, 3, 7, 1,
5}, {5, 6, 7, 8, 1, 2, 3, 4}, {6, 5, 8, 7, 2, 1, 4, 3}, {7, 3, 5,
1, 8, 4, 6, 2}, {8, 4, 6, 2, 7, 3, 5, 1}}]


d8b is, by construction, isomorphic to d8a. Some quick checks:

Both groups have order 8:

(Local) In:= GroupOrder /@ {d8a, d8b}

(Local) Out= {8, 8}


Each group has 2 elements of order 4, 5 of order 2, and 1 of order 1:

(Local) In:= Tally /@ (PermutationOrder /@ # & /@
GroupElements /@ {d8a, d8b})

(Local) Out= {{{1, 1}, {2, 5}, {4, 2}}, {{1, 1}, {2, 5}, {4, 2}}}


However, they look completely different. d8a is represented as a subgroup of $S_4$ with two generators. d8b is a subgroup of $S_8$ with 8 generators. Their group stabilizer chains don't resemble each other. If I was given these two groups without knowing where they came from, how would I find out that they're isomorphic?

All right, here is a solution: Find group isomorphisms in Mathematica. It's not pretty, but it's practical for groups of order up to about 100. It takes 30 ms to find out that $\text{d8a}\cong\text{d8b}$, and 43 ms to produce the automorphism group on my Mac mini. It finds an isomorphism from $S_5\to S_5$ (order 120) in 7 s. Producing all of $Aut(S_5)$ takes 27 s, since it has to test all possible mappings rather than stopping at the first success. It manages $S_6$ (order 720, $|\text{Aut}(S_6)|=1440$) in a little under 4 hours.

findGroupIsomorphisms[
group1_,
group2_,
max_: ∞
] :=
Module[{ng1, ng2, reverse, g1, g2, order, gs1, go1, gm1, gm2,
os1, os2, inng1, abelianQ, targets, isomorphisms, w1,
mt1, φm1, φ, homomorphismQ, t, ts},
(*
* Choose the domain group with fewest generators
*)
If[GroupOrder[group1] != GroupOrder[group2],
Return[{}];
];
{ng1, ng2} = Length[GroupGenerators[#]] & /@ {group1, group2};
reverse = ng2 < ng1;
If[reverse,
{g1, g2} = {group2, group1};
{ng1, ng2} = {ng2, ng1},
{g1, g2} = {group1, group2}
];
(*
* Do some quick checks for isomorphism
*)
order = GroupOrder[g1];
{gm1, gm2} = GroupElements /@ {g1, g2};
{os1, os2} = Map[PermutationOrder, {gm1, gm2}, {2}];
If[Sort[Tally[os1]] != Sort[Tally[os2]],
Return[{}]
];
(*
* Pick possible targets in g2
*)
gs1 = GroupGenerators[g1];
go1 = PermutationOrder /@ gs1;
targets = Table[
{n, go1}
];
targets = Tuples[targets];
(*
* List the inner automorphisms
*)
inng1 = Outer[
GroupElementPosition[
g1, #1\[PermutationProduct]#2\[PermutationProduct]\
InversePermutation[#1]] &,
gm1, gs1
];
inng1 = Union[inng1];
abelianQ = Length[inng1] == 1;
(*
*
Here I should do something much more efficient for abelian groups...
*)
(* Stub *)
(*
*
Test every possible mapping of the generators
*)
w1 = GroupElementToWord[g1, #] & /@ gm1;
mt1 = GroupMultiplicationTable[g1];
isomorphisms = {};
While[targets =!= {},
t = targets[[-1]]; targets = Drop[targets, -1];
φ = With[{t = t},
Function[i, GroupElementFromWord[PermutationGroup[t], w1[[i]]]]
];
ts = Map[φ, inng1, {2}];
targets = Complement[targets, ts];
If[GroupOrder[PermutationGroup[t]] != order,
Continue[]
];
φm1 =
GroupElementFromWord[PermutationGroup[t], #] & /@ w1;
homomorphismQ =
Map[φ, mt1, {2}] ==
Outer[PermutationProduct, φm1, φm1];
If[homomorphismQ,
(*
* We found some isomorphisms!
*)
isomorphisms = Join[isomorphisms, ts]
];
If[Length[isomorphisms] >= max,
Break[]
]
];
(*
* Return the isomorphisms as rule lists
*)
isomorphisms =
Take[isomorphisms, Min[max, Length[isomorphisms]]];
isomorphisms = {gs1, #} & /@ isomorphisms;
If[reverse, isomorphisms = Reverse /@ isomorphisms];
Apply[Rule, Transpose /@ isomorphisms, {2}]
]

isomorphicGroupsQ[group1_, group2_] :=
MatchQ[findGroupIsomorphisms[group1, group2, 1], {_}]

• Thank you for the code! I embedded it in your answer to make sure it won't get lost. I'm not sure about pastebin.com's policy on retaining pastes. Oct 17, 2015 at 16:18

For future searchers who come across this question, there is now a function FindGroupIsomorphism in the Wolfram Function Repository.