Polyhedron Coloring

Author

Eric W. Weisstein
September 23, 2015

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/PolyhedronColoring.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/PolyhedronColoring.html.

©2015 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Discussion and Polyhedron coloring code by
Oyvind Tafjord
October 6, 2004

Initialization

<<Combinatorica`

No faces with a common edge share the same color

solids=GraphData["Platonic"]

duals=GraphData[#,"DualGraph","Name"]&/@GraphData["Platonic"]

tab=GraphData[#,"ChromaticPolynomial"][n]&/@duals

Grid[Join[{{"solid",Sequence@@Range[4]}},Transpose[Join[{solids},Table[tab,{n,6}]]]],Dividers->{All,{2->Thick}},Frame->True,Alignment->{{Left,{Decimal}},Automatic}]

These do not take into account rotational equivalence, e.g., the “two” 2-colorings of the octahedron are actually identical since rotating by 90° is equivalent to swapping colors on faces.  Here is the correct table:

({{"solid", 1, 2, 3, 4, 5, 6}, {"CubicalGraph", 0, 0, 1, \[Placeholder], \[Placeholder], 30}, {"DodecahedralGraph", 0, 0, 0, 4, \[Placeholder], \[Placeholder]}, {"IcosahedralGraph", 0, 0, 144, \[Placeholder], 4, \[Placeholder]}, {"OctahedralGraph", 0, 1, \[Placeholder], \[Placeholder], \[Placeholder], \[Placeholder]}, {"TetrahedralGraph", 0, 0, 0, 2, \[Placeholder], \[Placeholder]}})

Using at most colors with no restrictions on adjacenct faces

Oyvind Tafjord
October 6, 2004

Discussion

To find the number of colorings of a polyhedron, you need to derive the symmetry group for the faces of the solid and then feed this to Polya[group, n]. Here's a (possibly inefficient) way of doing it, starting from the faces, deriving the corresponding graph, using Automorphisms to find all the symmetries (this takes a while), removing the symmetries that invert a face (we only want rotations, not inversions), then finding the induced symmetry group for the faces. There are surely much more straightforward ways of constructing this directly from other groups, but this should work any object for which the face information is known.

Note that PolyhedronFaces[solid] is the same as ToAdjacencyLists[dual graph]

Code

cycleit[l_]:=RotateLeft[l,Ordering[l][[1]]-1]
PolyhedronColoring[solid_,cols_]:=Module[{f,GroupIh,GroupI,GroupFaces},f=cycleit/@PolyhedronData[solid,"FaceIndices"];
GroupIh=Automorphisms[FromUnorderedPairs[Union[Sort/@Flatten[Partition[#,2,1,1]&/@f,1]]]];
GroupI=Select[GroupIh,MemberQ[f,cycleit[#[[f[[1]]]]]]&];
GroupFaces=KSubsetGroup[GroupI,Sort/@f];
Polya[GroupFaces,cols]
]

Cube

PolyhedronColoring["Cube",n]//Timing

Factor[((n^2)/3)+((n^3)/2)+((n^4)/8)+((n^6)/24)]

Table[((n^2)/3)+((n^3)/2)+((n^4)/8)+((n^6)/24),{n,10}]

A047780/M4716

Dodecahedron

PolyhedronColoring["Dodecahedron",n]//Timing

Table[((11 (n^4))/15)+((n^6)/4)+((n^12)/60),{n,10}]

Icosahedron

PolyhedronColoring["Icosahedron",n]//Timing

Table[((2 (n^4))/5)+((n^8)/3)+((n^10)/4)+((n^20)/60),{n,10}]

A054472

Octahedron

PolyhedronColoring["Octahedron",n]//Timing

Table[((n^2)/4)+((17 (n^4))/24)+((n^8)/24),{n,10}]

A000543

Tetrahedron

PolyhedronColoring["Tetrahedron",n]//Timing

Table[((11 (n^2))/12)+((n^4)/12),{n,10}]

A006008/M3854