# Counting automorphisms that preserve a group action

Note: the math, I believe, is not the problem here. The issue is not that I get the wrong answer, just that my code does not terminate. So, if you do not feel comfortable with the problem below, I do not believe it is necessary to diagnose the problem with my code.

The problem I am trying to solve (assuming you know some group theory) is

For a group $G$, consider the automorphisms $(\sigma_1,\sigma_2,\sigma_3)$ on $G\times G\times G$ that have the following property: if $(a,b,c)\in G\times G\times G$ are such that $ab=c$, then $\sigma_1(a)\sigma_2(b)=\sigma_3(c)$ (under the group action of $G$). For $G=\mathbb{Z}_n$, count the number of such automorphisms.

The first function, σ3, takes the inputs lines (a list of all $(a,b,c)\in \mathbb{Z}_n^3$ where $a+b\equiv c$), σ1, and σ2 each in an ordered tuple of length $n$. It then applies via rule1 and rule2 the first two permutations, $\sigma_1$ and $\sigma_2$. These determine some $\sigma3$ by the property that $\sigma_1(a)+\sigma_2(b)\equiv\sigma_3(c)$ for all $a,b,c\in\mathbb{Z}_n$ (although it may not be a valid permutation). The function then outputs ordered pairs: $(c,\sigma_3(c))$ for each element in lines.

σ3[lines_List, σ1_List, σ2_List] :=

Module[{rule1 = {}, rule2 = {}, lines1 = {}, lines2 = {},
original = {}, image = {}, n = 0},

n = Length[σ1];
lines1 = lines;

For[i = 1, i <= n, i++,
rule1 =
Map[If[#[] == i - 1, # :> {σ1[[i]], #[], #[]}] &,
lines] /. Null -> Sequence[];
lines1 = lines1 /. rule1;
];

lines2 = lines1;

For[i = 1, i <= n, i++,
rule2 =
Map[If[#[] == i - 1, # :> {#[], σ2[[i]], #[]}] &,
lines1] /. Null -> Sequence[];
lines2 = lines2 /. rule2;
];

original = Map[#[] &, lines];
image = Map[Mod[#[] + #[], n] &, lines2];

DeleteDuplicates[Partition[Riffle[original, image], 2]]
]


The second function the checks whether this is a valid permutation or not by checking the number of unique mappings of $c$ under $\sigma_3$ is the same as $\sigma_1$.

permCheck[lines_List, σ1_List, σ2_List] :=
Length[σ3[lines, σ1, σ2]] == Length[σ1];


Finally, the function znPerms generates the list of $(a,b,c)\in \mathbb{Z}_n^3$ such that $a+b\equiv c$ in the form of nested lists, generates a list of pairs of all possible permutations $\sigma_1$ and $\sigma_2$ (I know, crazy), and then, using permCheck and σ3, makes sure they generate a valid permutation $\sigma_3$. For each valid permutation, we increment count and then return count.

znPerms[n_] := Module[{lines = {}, allPerms = {}, count = 0},

lines =
Select[Tuples[Range[0, n - 1], 3],
Mod[#[] + #[], n] == #[] &
];

allPerms = Tuples[Permutations[Range[0, n - 1], {n}], 2];

For[i = 1, i <= Length[allPerms], i++,
If[
permCheck[lines, allPerms[[i, 1]], allPerms[[i, 2]]],
count++;
];
];

Return[count];
];


Although this is not feasible for many positive integers since the complexity grows on the order of $n!^2$ (I don't know if that's the correct wording), znPerms should be fairly easy to compute as the list of pairs of all possible permutations is only of length 36. Alas, it does not terminate when executed.

I have tried encapsulating many parts of this code in With and testing it individually and everything seems to be working fine. It's only when it's all put together with znPerms that it gets stuck.

Any insight?

• Like this? t = Tuples[Permutations[{1, 2, 3}], 3]; gg = {0, 1, 2}; table = And @@@ (MapThread[ Mod[gg[[#1]] + gg[[#2]], 3] == gg[[#3]] &, #] & /@ t); Pick[t, table] – Dr. belisarius Mar 26 '16 at 0:20
• Wow, if this works that's incredibly shorter. I have a rough idea of what the table = And @@@... line is doing but this produces the correct number of autmorphisms for $\mathbb{Z}_3$. I can't seem to generalize this to $\mathbb{Z}_n$. – Gerald Mar 26 '16 at 0:41
• The problem is that the Tuples[ ] thing explodes quickly. Let me generalize it anyway. – Dr. belisarius Mar 26 '16 at 0:44
• With $n=4$, this returns the empty set, the problem I was having generalizing this. With $n=5$, it gives an error about running out of memory. I realize that the permutation we are checking is of size $5!^3=1728000$, but that still seems like a reasonable number for Mathematica to handle. I have 16 GB (13 GB free) of RAM and I believe that is the memory in question. I understand $n=10$ may be out of the question, but 5 seems feasible. – Gerald Mar 26 '16 at 0:54
• Something like getAutomfsms[n_] := Module[{t, gg, table}, t = Tuples[Permutations[Range@n], 3]; gg = Range[0, n - 1]; table = And @@@ (MapThread[ Mod[gg[[#1]] + gg[[#2]], n] == gg[[#3]] &, #] & /@ t); Pick[t, table] ] getAutomfsms. But yes, it is bruteforcing it, so it explodes very quickly – Dr. belisarius Mar 26 '16 at 0:55