Return to Answer

AutG = GroupElements[GraphAutomorphismGroup[g1]];
clist = AllLabeledColorings[g1];
sol = Tally[
  Function[c, 
    Function[h, 
      KeySort@KeyMap[Function[v, PermutationReplace[v, h]], c]] /@ 
     AutG] /@ clist, ContainsExactly];(*This code takes about 50 seconds to run*)
sol[[All, 2]](*List of the number of schemes repeated with each feasible dyeing scheme*)
CountDistinct /@ Values /@ sol[[All, 1, 1]](*Number of colors used for each scheme*)
Tally[CountDistinct /@ Values /@ sol[[All, 1, 1]]]

AutG = GroupElements[GraphAutomorphismGroup[g1]];(*正六面体旋转或反射后的48个同构*)
clist = AllLabeledColorings[g1];(*先找到4080个两个共棱面颜色不同的染色方案*)
sol = Tally[
  Function[c, 
    Function[h, 
      KeySort@KeyMap[Function[v, PermutationReplace[v, h]], c]] /@ 
     AutG] /@ clist, ContainsExactly];(*This code takes about 50 seconds to run*)
 (*找到这4080个方案的每一个的图的48个同构;然后判断4080个48同构子集之间是否重复，去重*)
sol[[All, 2]](*List of the number of schemes repeated with each feasible dyeing scheme*)
CountDistinct /@ Values /@ sol[[All, 1, 1]](*Number of colors used for each scheme*)
Tally[CountDistinct /@ Values /@ sol[[All, 1, 1]]]

Where num1 = num3, this conclusion is very useful. But one thing I'm confused about is that groups G1 and G2 are both groups of order 48, representing regular hexahedral groups. Why are num2 and num3 not equal? I want to know the underlying reasons for their different results.

Where num1 = num3, this conclusion is very useful. But one thing I'm confused about is that groups G1 and G2 are both groups of order 48, representing regular hexahedral groups. Why are num2 and num3 not equal? I want to know the underlying reasons for their different results.

Comparison with the results of standard answers:

AutG = GroupElements[GraphAutomorphismGroup[g1]];
clist = AllLabeledColorings[g1];
sol = Tally[
  Function[c, 
    Function[h, 
      KeySort@KeyMap[Function[v, PermutationReplace[v, h]], c]] /@ 
     AutG] /@ clist, ContainsExactly];(*This code takes about 50 seconds to run*)
sol[[All, 2]](*List of the number of schemes repeated with each feasible dyeing scheme*)
CountDistinct /@ Values /@ sol[[All, 1, 1]](*Number of colors used for each scheme*)
Tally[CountDistinct /@ Values /@ sol[[All, 1, 1]]]

(3  20
 4  90
 5  90
 6  15)

It can be seen that there are 15 schemes using 6 colors, which is different from the result of the reference answer.

g1 = Graph[(Sort /@ 
      Flatten[Map[
        Thread[#[[1]] \[UndirectedEdge] #[[2]]] &, {{1, {2, 3, 4, 
           5}}, {2, {1, 3, 5, 6}}, {3, {1, 4, 2, 6}}, {4, {1, 3, 5, 
           6}}, {5, {1, 2, 4, 6}}, {6, {2, 3, 4, 5}}}]]) // 
    DeleteDuplicates, 
   VertexLabels -> "Name"];(*Adjacency between faces*)

UnrestrictedColoringQ[g_, coloring_Association] := 
  ContainsExactly[VertexList[g], Keys[coloring]];

ColoringQ[g_, c_Association] := 
  FreeQ[Map[c, EdgeList[g], {2}], v_ \[UndirectedEdge] v_, 1] /; 
   UnrestrictedColoringQ[g, c];

AllUnrestrictedColorings[g_] := 
  With[{vs = VertexList[g]}, 
   AssociationThread[vs, #] & /@ 
    Tuples[Table[i, {i, Length[vs]}], Length[vs]]];

AllLabeledColorings[g_] := 
  Select[AllUnrestrictedColorings[g], ColoringQ[g, #] &];

AutMod[g_, clist : {___Association}, autg_List : Null] := 
 With[{AutG = 
    Replace[autg, Null :> GroupElements[GraphAutomorphismGroup[g]]]}, 
  DeleteDuplicates[
   Function[c, 
     Function[h, 
       KeySort@KeyMap[Function[v, PermutationReplace[v, h]], c]] /@ 
      AutG] /@ clist, ContainsExactly]]


(*With g1 as above:*)
H = GroupElements@
   PermutationGroup[{Cycles[{{2, 3, 4, 5}}], Cycles[{{1, 2, 6, 4}}]}];
G1 = GroupElements@
   FiniteGroupData["Octahedral", "PermutationGroupRepresentation"];
G2 = GroupElements@
   PermutationGroup[{Cycles[{{2, 3, 4, 5}}], Cycles[{{1, 2, 6, 4}}], 
     Cycles[{{1, 6}}]}];
num1 = AutMod[g1, AllLabeledColorings[g1]] // Length
num2 = AutMod[g1, AllLabeledColorings[g1], G1] // Length
num3 = AutMod[g1, AllLabeledColorings[g1], G2] // Length
num4 = AutMod[g1, AllLabeledColorings[g1], H] // Length

The above code takes about 800 seconds to calculate num2. And the results of the above codes are 215, 1860, 215, 230.

g1 = Graph[(Sort /@ 
      Flatten[Map[
        Thread[#[[1]] \[UndirectedEdge] #[[2]]] &, {{1, {2, 3, 4, 
           5}}, {2, {1, 3, 5, 6}}, {3, {1, 4, 2, 6}}, {4, {1, 3, 5, 
           6}}, {5, {1, 2, 4, 6}}, {6, {2, 3, 4, 5}}}]]) // 
    DeleteDuplicates, 
   VertexLabels -> "Name"];(*Adjacency between faces*)

UnrestrictedColoringQ[g_, coloring_Association] := 
  ContainsExactly[VertexList[g], Keys[coloring]];

ColoringQ[g_, c_Association] := 
  FreeQ[Map[c, EdgeList[g], {2}], v_ \[UndirectedEdge] v_, 1] /; 
   UnrestrictedColoringQ[g, c];

AllUnrestrictedColorings[g_] := 
  With[{vs = VertexList[g]}, 
   AssociationThread[vs, #] & /@ 
    Tuples[Table[i, {i, Length[vs]}], Length[vs]]];

AllLabeledColorings[g_] := 
  Select[AllUnrestrictedColorings[g], ColoringQ[g, #] &];

AutMod[g_, clist : {___Association}, autg_List : Null] := 
 With[{AutG = 
    Replace[autg, Null :> GroupElements[GraphAutomorphismGroup[g]]]}, 
  DeleteDuplicates[
   Function[c, 
     Function[h, 
       KeySort@KeyMap[Function[v, PermutationReplace[v, h]], c]] /@ 
      AutG] /@ clist, ContainsExactly]]


(*With g1 as above:*)
H = GroupElements@
   PermutationGroup[{Cycles[{{2, 3, 4, 5}}], Cycles[{{1, 2, 6, 4}}]}];
G1 = GroupElements@
   FiniteGroupData["Octahedral", "PermutationGroupRepresentation"];
G2 = GroupElements@
   PermutationGroup[{Cycles[{{2, 3, 4, 5}}], Cycles[{{1, 2, 6, 4}}], 
     Cycles[{{1, 6}}]}];
num1 = AutMod[g1, AllLabeledColorings[g1]] // Length
num2 = AutMod[g1, AllLabeledColorings[g1], G1] // Length
num3 = AutMod[g1, AllLabeledColorings[g1], G2] // Length
num4 = AutMod[g1, AllLabeledColorings[g1], H] // Length
GraphAutomorphismGroup[g1] // GroupOrder(*It is shown that graph G1 is isomorphic to its rotated and flipped graphs*)

The above code takes about 800 seconds to calculate num2. And the results of the above codes are 215, 1860, 215, 230 , 48.