How to correctly enumerate all the schemes of this cube coloring problem?
Be warned: this is a long answer, because I'm trying to be sufficiently general to treat basic graph colorings in Mathematica and maximally explanatory for anyone reading.
tl;dr: Define graph colorings; create functions that identify generate colorings; then quotient the set of colorings by the graph automorphisms, by creating literal equivalence classes of colorings. Count the number of resulting equivalence classes. Get 215 instead of 230; find that the reference answer has double-counted the number of 6-colorings by accident—or that the question is actually slightly different than as translated, and recover 230 in that case!
(Note: code presented in full near the bottom.)
Intro
Encoding it as a graph and looking at colorings is a good strategy! However, we need to take into account two things:
ChromaticPolynomial[g, k]gives colorings using exactlykcolors, whereas you need to choose up tok = 6colorsChromaticPolynomial[g, k]considers graphs to be labeled, and so, for example, there are, according toChromaticPolynomial, 2 colorings of the graph1 •-• 2.
We could do this by "standard" combinatorial methods, like counting how many possibilities there are for the placement of successive colors, but I want to try to stick with your graph strategy.
The second graph g1, encoding faces as graph vertices and edges as connections, is the relevant one.
Unfortunately, Mathematica doesn't have built-in graph coloring utilities beyond ChromaticPolynomial. So, we'll need to build our own.
Building a solution
Defining and checking graph colorings
Let's choose a form to represent graph colorings with. A(n unrestricted) graph coloring is an assignment from each vertex in a graph to a color. So let's encode a coloring as an association on graph vertices, e.g.:
<| v1 -> color1, v2 -> color2, ..., vn -> colorn |>
This is not the most efficient way to do this. A more efficient way would be to simply use a list of colors, with the color in the nth position indicating the color of the nth vertex in VertexList[g]. But that's okay.
So, let's write a function that tests if a given coloring is even a well-formed assignment of colors to a given graph's vertex set, not even requiring adjacent vertices are differently colored yet:
UnrestrictedColoringQ[g_, coloring_Association] :=
ContainsExactly[VertexList[g], Keys[coloring]]
Ok. Now let's test if it's an actual graph coloring, i.e. that no two adjacent vertices have the same color. We'll do this by mapping the association over the edges, which will replace each vertex with its color (here c is our function/association)—we do this by mapping over the edge list at the 2nd level. For example, written out stylistically instead of with \[UndirectedEdge], just for showing the result:
In[1]:= Map[c, {1 •-• 2, 2 •-• 3}, {2}]
Out[1]:= {c[1] •-• c[2], c[2] •-• c[3]}
The question is then whether we wind up with a color connected to a color n the output. If so, then two adjacent vertices have been assigned the same color by c. We want to check that this is avoided. That is, we want to check that that self-loops, loops of the kind a •-• a, do not appear. We'll do this with FreeQ[result, v_ \[UndirectedEdge] v_]. (Note: This assumes undirected edges; we could include directed edges by providing a couple alternatives to the pattern via |.)
So, putting this all together,
ColoringQ[g_, c_Association] :=
FreeQ[Map[c, EdgeList[g], {2}], v_ \[UndirectedEdge] v_, 1] /; UnrestrictedColoringQ[g, c]
where the /; checks that c is at least an unrestricted coloring first. (If we were really building a package, we'd probably want to return an error message in that case instead.) Also note that the 1 in FreeQ just restricts us to testing the first level for safety.
Generating colorings
Okay, now let's build our colorings that select from a set of 6 colors. There are much better algorithms for doing this, but we're going to do it by brute force, since we only need to consider 6^6 == 46656 colorings.
We can get all lists of 6 elements drawn from the 6 colors {1,2,3,4,5,6} via Tuples[{1,2,3,4,5,6}, 6], or in general, Tuples[Table[i, {i, Length @ VertexList[g]}], Length @ VertexList[g]].
We then want to make these into unrestricted colorings, i.e. associations; we can do this with AssociationThread, e.g. AssociationThread[VertexList[g], {4,6,2,2,1,2}] produces the association we want it to. So,
AllUnrestrictedColorings[g_] := With[{vs = VertexList[g]},
AssociationThread[vs, #] & /@ Tuples[Table[i, {i, Length[vs]}], Length[vs]]]
We can then select the ones that are colorings. This considers isomorphic colorings inequivalent if the color labels and vertex labels are different, so we'll reflect that in the name:
AllLabeledColorings[g_] := Select[AllUnrestrictedColorings[g], ColoringQ[g, #] & ]
Modding out by vertex relabeling
Now comes the interesting part. We want to consider the action under reflections and rotations of the cube. Mathematically, we're modding out by the action of that symmetry group. Usually this is done by creating equivalence classes, and while there are more efficient ways to do it computationally, let's reflect the typical mathematical procedure.
Now, it happens that reflections and rotations of the cube correspond exactly to graph automorphisms of g1. Mathematica has a function to produce the automorphism group of a graph, namely GraphAutomorphismGroup. We can get the list of group elements with GroupElements, and then apply these to a list of vertices by Permute[list, groupelement] or for a single element by PermutationReplace. We'll map over the keys in each association in this implementation; if we were taking colorings to be lists instead of associations, the first strategy might be relevant.
Note that this does not account for isomorphic colorings up to relabeling of colors; for example, on the graph 1 •-• 2 •-• 3, if our colors are R, G, B, then this considers R-G-R to be inequivalent to R-B-R and B-R-B (etc.) This is what you want, though.
So, if AutG is the list of group elements, a single equivalence class for a coloring c is
Function[h, KeyMap[Function[v, PermutationReplace[v, h]], c]] /@ AutG
Note: This assumes that our vertices are integers. In general, we'd need to use VertexIndex to turn it into an integer, permute, then extract the right vertex from VertexList. (Or permute the VertexList directly via Permute.)
Now, for implementation reasons (namely that <| a -> x, b -> y |> is not equal to <| b-> y, a-> x |>) we'll want to sort the resulting associations by the keys. So, instead, we want,
Function[h, KeySort @ KeyMap[Function[v, PermutationReplace[v, h]], c]] /@ AutG
We're going to package this into a function with parameter c then map over the list of colorings. Once we do, we want to delete equivalent, uh, equivalence classes (i.e. equivalence classes with the same elements) by DeleteDuplicates with function ContainsExactly.
Putting this all together, for a list of colorings clist, we can write
AutMod[g_, clist : {___Association}] := With[{AutG = GroupElements[GraphAutomorphismGroup[g]]},
DeleteDuplicates[
Function[c,
Function[h, KeySort @ KeyMap[Function[v, PermutationReplace[v, h]], c]] /@ AutG
] /@ clist,
ContainsExactly]
]
Now
AutMod[g1, AllLabeledColorings[g1]]
should give us all inequivalent (in the context of this problem) colorings. The length of this should be the number of dyeing schemes.
The result
Our result
Now. This works. It takes a while to run. Your computation, which was posted after I began writing this, is much more efficient, but this reflects the underlying math more readably in my opinion, and is therefore easier to trust (for me, at least); and it's generalizable (at least to other small graphs!). However, after consideration, I believe your approach, which appears to use neighborhoods, might be generalizable too, and is certainly nicer computationally. If we wanted to make the above more efficient while using the same strategies, e.g. by encoding colorings differently, I think we could, and we might end up with something similar to what you have.
The answer this produces, though, is 215. The given answer is 230. I'm pretty confident in the above determination of 215 because of the underlying mathematics, and from testing some smaller graphs.
Why the competition is wrong
Further, let's examine the reference answer. They count 30 configurations using all 6 colors, arguing roughly as follows:
Fix a certain color on the top, leaving 5 options for the bottom, and $(4-1)! = 6$ colors for the remaining 4 sides, totaling 30 methods.
However, they have double-counted the configurations for the remaining 4 sides, as they have forgotten to account for the reflection that identifies two of the 4 sides.
The fact that we may fix one color on the top and have 5 choices for the bottom is correct. When considering how many options there are for the four remaining sides spoken of, we must imagine rotating the cube to fix one of the remaining 4 colors, on, say, the North face (so no choice has been made); then the choice of color for the South face is among all 3 remaining colors. The remaining two possible assignments of colors to the East and West faces are equivalent, by considering thee reflection that exchanges the East and West axis, so there is only actually 1 choice remaining. So the total number of possibilities is 5 times 3 times 1 (15), not 30. Hence, we conclude that the reference answer is in error, and 215 is the correct answer!
Why the competition is right (and checking it)
However, this whole computation might be predicated on a translation error. I've assuming that "proper flipping" means a flipping that is nontrivial, i.e., is actually a flipping operation (has determinant $-1$). But it strikes me that if "flipping" actually means something more like "orthogonal transformation" or "rotation", and "proper" means a member of the special orthogonal group, then this means the opposite—that we only allow things with determinant 1!
Indeed, in that case, the competition's answer is correct. Let's verify that by generalizing our code for AutMod to allow arbitrary automorphism groups:
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]
]
(If we were being more precise, we'd probably check if it were a subgroup of the graph automorphism group.)
Then realize that the group of proper rotations may be generated by two 90 degree rotations, which here may be realized as the cycles Cycles[{{2, 3, 4, 5}}] and Cycles[{{1, 2, 6, 4}}] upon examining the specific form of g1 given. Then take
H = GroupElements @ PermutationGroup[{Cycles[{{2, 3, 4, 5}}], Cycles[{{1, 2, 6, 4}}]}]
and we indeed find that
AutMod[g1, AllLabeledColorings[g1], H]
has Length equal to 230.
The code
Here's all of the code presented in full:
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}}]}];
AutMod[g1, AllLabeledColorings[g1]] // Length
AutMod[g1, AllLabeledColorings[g1], H] // Length
Another approach
There's also another way we could do this: by procedural choices in a manner paralleling the competition.
Order your colors 1 through 6. Up to rotation + flipping (i.e. isometry), we can demand that the least-ranked color appearing be on the bottom. Now, up to isometry, there are 2 choices for the second-least-ranked color (which might be the same color!): opposite the least or adjacent to it. If it's adjacent, it cannot be the same color. Now take the third-least ranked color—etc. It's a big tree of case analysis. We can get Mathematica to do that too! I think this is essentially what you achieve in your third code snippet.
The key here is that after we choose some particular vertices to color, the symmetry group reduces to the stabilizer of those vertices (i.e. the elements of the automorphism group that preserve it). Given a current symmetry group, our choice lies only in what orbit to place the color in, as all choices within a given orbit are the same up to that symmetry (practically by definition).
When I have the chance I'll update this answer with a description of how to do this in Mathematica.