4
$\begingroup$

This problem is the fifth question of 1996 Chinese High School Mathematics League or Chinese Mathematical Olympiad in Senior:

Choose several colors from the given six different colors to dye six faces of a cube, and dye each two faces with common edges into different colors. How many different dyeing schemes are there?

Note: if we dye two identical cubes, we can make the six corresponding faces of the two cubes dyed the same by proper flipping, then we say that the two cubes have the same dyeing scheme.

Show[Graphics3D[
  Rotate[Cuboid[{0, 0, 0}, {1, 1, 1}], 0 Degree, {0, 0, 1}], 
  Axes -> True], i = 1;
 Graphics3D[
  Table[Text[Style[ToString[i++], 15], {x, y, z}], {x, 0, 1}, {y, 0, 
    1}, {z, 0, 1}]]]

enter image description here

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

poly = CycleIndexPolynomial[DihedralGroup[8], 
  Array[Subscript[a, ##] &, 6]]

enter image description here

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*)
ChromaticPolynomial[g1, 6]

The above method may not consider the restriction that the color of adjacent faces can not be the same, and does not eliminate the same dyeing situation after rotation, so there are many unreasonable schemes.


    f = Table[{i, Delete[Range[6], {{i}, {7 - i}}]}, {i, 6}];(*A face and its adjacent 4 faces*)
    g = Table[{i, 7 - i}, {i, 3}];
    DeleteDuplicatesBy[
      Select[MapThread[Rule[#1, #2] &, {Range[6], #}] & /@ 
        Tuples[{Black, White, Red, Green, Yellow, Cyan}, {6}], 
       Cases[f /. #, {x_, {___, x_, ___}}] == {} &(*Detect whether a face has the same color as its four adjacent faces*)], 
      Sort[Sort /@ (g /. #)] &(*Remove duplication*)] // Length

The results of the above codes are 198030 , 4080 and 215, but the reference answer is 230 (Maybe I didn't effectively exclude the same dyeing scheme after rotation). How to correctly list all the solutions to this problem?

With reference answers:

enter image description here

f = Table[{i, Delete[Range[6], {{i}, {7 - i}}]}, {i, 6}];
g = Table[{i, 7 - i}, {i, 3}];
sol = Values /@ DeleteDuplicatesBy[
      Select[MapThread[Rule[#1, #2] &, {Range[6], #}] & /@ 
          Tuples[{Black, White, Red, Green, Yellow, Cyan}, {6}], 
        Cases[f /. #, {x_, {___, x_, ___}}] == {} &], 
      Sort[Sort /@ (g /. #)] &] ;

newsol = Map[#[[{1, 3, 2, 4, 5, 6}]] &, 
   sol];(*Adjust the display order of faces*)
newsol // Length

(Graphics3D[{Specularity[0, 10], 
      Rotate[Thread[{#, 
         MeshPrimitives[Cuboid[{0, 0, 0}, {1, 1, 1}], 2]}], 
       0 Degree, {0, 0, 1}]}, 
     Lighting -> ({"Directional", White, #} & /@ 
        Tuples[{-1, 1}, 
         3])(*Diffuse light sources are arranged at four corners Or use a white scattering light source: Lighting -> {{"Ambient", White}}*)] & \
/@ newsol[[1 ;; 9]]) // Multicolumn

enter image description here

octahedralgroup=MatrixForm /@ FiniteGroupData["Octahedral", "MatrixRepresentation"]
Det /@ FiniteGroupData["Octahedral", "MatrixRepresentation"]

Acknowledgements: Thank you very much for the detailed answers provided by thorimur. I hope community members can provide more and more ingenious methods (additional reward).

$\endgroup$
10
  • 1
    $\begingroup$ Are you working through all of the combinatorial exercises in a textbook? $\endgroup$ – JimB Feb 21 at 18:28
  • $\begingroup$ @JimB Yes, but it's an exercise problem that I can't solve. It's different from the conventional problem without different color restrictions. I don't know how to solve this problem effectively at present. $\endgroup$ – A little mouse on the pampas Feb 21 at 20:16
  • $\begingroup$ I got the third answer—215—so I'm wondering if there's some peculiarity in the question statement or the notion of proper flipping that I'm missing. Unfortunately, the webpage you linked isn't loading for me. Do they explain how they got it? $\endgroup$ – thorimur Feb 21 at 23:17
  • 1
    $\begingroup$ Thinking about your code, Sort[Sort /@ (g /. #)] & is a really cool invariant. What was your reasoning behind it? I think it could be interesting to consider it in its general mathematical context. $\endgroup$ – thorimur Feb 22 at 0:13
  • 1
    $\begingroup$ Ok, I figured it out! Either the competition is incorrect, or there's been a translation error. Assuming the latter and guessing at the "right" translation, I modified my code and recovered 230, and updated my answer to explain it. $\endgroup$ – thorimur Feb 22 at 3:54
11
+100
$\begingroup$

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:

  1. ChromaticPolynomial[g, k] gives colorings using exactly k colors, whereas you need to choose up to k = 6 colors
  2. ChromaticPolynomial[g, k] considers graphs to be labeled, and so, for example, there are, according to ChromaticPolynomial, 2 colorings of the graph 1 •-• 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.

$\endgroup$
9
  • $\begingroup$ You'd better attach a complete code at the end to facilitate debugging. Besides, I didn't find the definition of function AutG. $\endgroup$ – A little mouse on the pampas Feb 22 at 1:04
  • 1
    $\begingroup$ Ok, cool, added. Also, by the way, AutG is the list of group elements in the graph automorphism group; it's only used in AutMod, which defines it via a With statement. $\endgroup$ – thorimur Feb 22 at 3:05
  • 1
    $\begingroup$ Your second piece of code (230) seems to be missing a symbol ]. $\endgroup$ – A little mouse on the pampas Feb 22 at 4:48
  • $\begingroup$ ah, thank you; fixed. $\endgroup$ – thorimur Feb 22 at 5:32
  • 1
    $\begingroup$ And indeed, we can check that that group and the graph automorphism group have the same elements: ContainsExactly[GroupElements@PermutationGroup[{Cycles[{{2, 3, 4, 5}}], Cycles[{{1, 2, 6, 4}}], Cycles[{{1, 6}}]}], GroupElements@GraphAutomorphismGroup[g1]] gives True. $\endgroup$ – thorimur Feb 22 at 17:52
1
$\begingroup$

It's not an original answer, it's just a supplement to the answer of thorimur.

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.

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]];(*正六面体旋转或反射后的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]]]
(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.

$\endgroup$
3
  • 1
    $\begingroup$ So, one reason num2 ≠ num3 is: despite being an isomorphic group to our graph automorphism group, FiniteGroupData["Octahedral", "PermutationGroupRepresentation"], knows nothing about how we've numbered our graph vertices. That information is particular to g1 and the groups derived from it. As such, when it tries to, say, "exchange opposite faces", it might actually be exchanging adjacent faces, because it could be using diifferent names for the vertices. Also... $\endgroup$ – thorimur Feb 24 at 0:29
  • $\begingroup$ ...and more fundamentally, permutation group representations of a given group are not unique, even in properties of the permutations. For example, we know that our representation of this group, which is represented as acting on faces, includes a cycle that only exchanges two elements: Cycles[{{1,6}}] for example. But upon inspecting the GroupElements of the above, you'll find no such permutation among them. Further, you'll find this group is represented via permutations on 8 elements, whereas we use only 6. Nonetheless, as groups, they are still isomorphic in the abstract. $\endgroup$ – thorimur Feb 24 at 0:37
  • $\begingroup$ @thorimur Thank you very much for your kind help. $\endgroup$ – A little mouse on the pampas Feb 24 at 1:55

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.