What is the order of faces on a D20? How can I optimize the order of faces on a D-n?

Question

I am creating a customizable D20 for 3D printing using OpenSCAD, with the following code:

factor=5;
$fn=10;
PHI=(1+sqrt(5))/2;
//Taken from: http://en.wikipedia.org/wiki/Icosahedron#Cartesian_coordinates
//Specifically: http://en.wikipedia.org/w/index.php?title=Icosahedron&oldid=568753314#Cartesian_coordinates
POINTS =    [   [0,-1,-PHI] , [0,-1,+PHI] , [0,+1,-PHI] , [0,+1,+PHI] ,
                [-1,-PHI,0] , [-1,+PHI,0] , [+1,-PHI,0] , [+1,+PHI,0] ,     
                [-PHI,0,-1] , [+PHI,0,-1] , [-PHI,0,+1] , [+PHI,0,+1] 
            ]*factor;

FACES =[    [1,3,11],[1,11,6], [1,6,4], [1,4,10],[1,10,3], 
            [3,5,7], [3,7,11], [3,5,10],[11,6,9],[11,7,9],
            [0,6,9], [0,6,4],  [0,8,4], [10,8,4],[10,8,5],
            [2,8,5], [0,2,9],  [0,2,8], [7,2,9], [5,2,7]];

function normal(n) =
//Calculates the position of the center of the nth face (also called the normal vector of the face)
    POINTS[FACES[n][0]]/3 +
    POINTS[FACES[n][1]]/3 +
    POINTS[FACES[n][2]]/3 ;

//spheres at each vertex
hull(){
    for(i=[1:12]){
        translate(POINTS[i-1]) sphere(.0001);
        }
    }

An icosahedron has 12 vertices given by POINTS, and the faces (triangles) are formed by the triplets in FACES where each number i is the i-th element in the list POINTS. OpenSCAD uses the C convention where the first element is 0, not 1.

Typical dice are numbered so that for an N-sided die, the number on a given side, and the number on an opposite side add up to N+1. How can I tell Mathematica to find the order of faces so that "ONE" should be placed at the face given by FACES[[1]], and all the other numbers should have the N+1 property above.

For a given solid that would work as a die, is there another condition I have to apply? e.g. is it necessary or optimal to enforce or check that the sum of numbers around a given vertex (or edge?) is not more than a certain amount than the sum from another vertex or edge? From this picture (https://en.wikipedia.org/wiki/Dice#mediaviewer/File:6sided_dice.jpg) it seems that on a normal D6 that there is a vertex that is adjacent to 4,5,6 and therefore the opposite vertex is adjacent to 1,2,3.

Here are the data in Mathematica format:

PHI=(1+Sqrt[5])/2;
POINTS = { {0,-1,-PHI} , {0,-1,+PHI} , {0,+1,-PHI} , {0,+1,+PHI} ,{-1,-PHI,0} , {-1,+PHI,0} , {+1,-PHI,0} , {+1,+PHI,0} , {-PHI,0,-1} , {+PHI,0,-1} , {-PHI,0,+1} , {+PHI,0,+1} };
FACES ={ {1,3,11},{1,11,6}, {1,6,4}, {1,4,10},{1,10,3}, {3,5,7}, {3,7,11}, {3,5,10},{11,6,9},{11,7,9}, {0,6,9}, {0,6,4}, {0,8,4}, {10,8,4},{10,8,5}, {2,8,5}, {0,2,9}, {0,2,8}, {7,2,9}, {5,2,7}};

Since you've listed by hand all the data so far, I'd use the property that the coordinates of the vertices of opposite faces are negatives of each other and list them by hand. — Michael E2, Jul 18 '14 at 13:07
I'd use Gather with "is parallel to" as criterion. That way you'd get a list of pairs, containing sites opposite to each other. Then you could use Transpose on that list, and then Reverse on the second element of the result. Then apply Join to get back to a single list. Then the positions in the list are such that the opposite sides have indices which add to the same number (namely $d+1$ for a D$d$), so you can just give each side its index in that list as number. — celtschk, Jul 18 '14 at 13:11
Accordind to the normal 6-sided cube-shaped die, as soon as you add the condition that opposite sides add up to 7, there are only two possible distributions which are mirror images to each other. Quite obviously this means that you'll not find a possible distribution that dos not have a vertex adjacent to 1,2,3 — which can also be seen quite directly: opposite to 1 is 6, so adjacent to it can only be 2 to 5. Now 2 and 3 are not opposite, thus they are adjacent. Since 1, 2 and 3 are pairwise adjacent, they share a vertex. And the opposite vertex then of course is shared by 4, 5 and 6. — celtschk, Jul 18 '14 at 13:24
Also note that for the use of a regular polyhedron as a die, it is completely irrelevant how you distribute the numbers, as long as each number appears exactly once (if it were not irrelevant, the die would not be unbiased to begin with). Indeed, taking into account possible biases, the usual opposite-side rule is the worst you can do; since the opposite side of the most probable result will be the least probable result, opposite sides should be as close as possible to minimize the effect of unintentional bias. — celtschk, Jul 18 '14 at 13:28

Michael E2 · Answer 1 · 2014-07-30T16:45:20.313

Here's a way to number the faces completely within Mathematica. Most of the information about polyhedra needed for this is already in Mathematica in PolyhedronData.

If you do not have V10, then Needs["GeneralUtilities`"] may be omitted and Where replaced with CompoundExpression.

Opposite faces are identified by their centroids having coordinate that are the negatives of one another (since the icosahedron below is symmetric about the origin). After pairing them up, we can transpose the list and reverse one of the components. This will make the sum of the face numbers be n + 1.

Needs["GeneralUtilities`"];    (* V10 req'd *)
Where[                         (* If before V10, replace Where -> CompoundExpression *)
  v =            PolyhedronData["Icosahedron", "VertexCoordinates"],
  fidx =         PolyhedronData["Icosahedron", "FaceIndices"],
  fctrs =        Mean@v[[#]] & /@ fidx,
  faceordering = GatherBy[Range@20, Sort[{fctrs[[#]], -fctrs[[#]]}] &];
  faces =        fidx[[Join[First[#], Reverse@Last[#]] &@Transpose@faceordering]]
  ];

d20 = Graphics3D[
  GraphicsComplex[
   PolyhedronData["Icosahedron", "VertexCoordinates"],
   MapThread[
    {Texture[Framed[#1, Background -> #3, FrameMargins -> {{5, 5}, {5, 25}}, FrameStyle -> None]], 
      Polygon[#2, VertexTextureCoordinates -> {{0, 1/10}, {1, 1/10}, {1/2, 7/10}}]} &,
    {Range@20,
     faces,
     Array[Hue[3 Abs[# - 10.5]/10.5, 0.7, 0.9] &, {20}]}]
  ],
  Lighting -> "Neutral"];

GraphicsRow[{
  Show[d20, ViewPoint ->  { -2.4, -1.3, -1.}, ViewVertical ->  {0, 0, 1}],
  Show[d20, ViewPoint -> -{ -2.4, -1.3, -1.}, ViewVertical -> -{0, 0, 1}]
  }]

Mathematica graphics

Thank you. Very compact solution. From @Celtschk 's answer I was able to figure out that faces-1 gives me the data I need. — DrXenocide, Jul 21 '14 at 11:28

score 4 · Accepted Answer · answered Jul 18 '14 at 18:39

OK, here's the code to do it. First, for completeness, your definitions:

PHI=(1+Sqrt[5])/2;
POINTS={{0, -1, -PHI}, {0, -1, +PHI}, {0, +1, -PHI}, {0, +1, +PHI},
        {-1, -PHI, 0}, {-1, +PHI, 0}, {+1, -PHI, 0}, {+1, +PHI, 0},
        {-PHI, 0, -1}, {+PHI, 0, -1}, {-PHI, 0, +1}, {+PHI, 0, +1}};
FACES={{1, 3, 11}, {1, 11, 6}, {1, 6, 4}, {1, 4, 10}, {1,10,3},
       {3, 5, 7}, {3, 7, 11}, {3, 5, 10}, {11, 6, 9}, {11, 7, 9},
       {0, 6, 9}, {0, 6, 4}, {0, 8, 4}, {10, 8, 4}, {10, 8, 5},
       {2, 8, 5}, {0, 2, 9}, {0, 2, 8}, {7, 2, 9}, {5, 2, 7}};

Then the functions doing all the interesting work:

ClearAll[isParallel];
isParallel::usage="The function areParallel[poly1,poly2] gives True if
 the two arguments, describing polygons in three-dimensional space, are
 parallel, and False if they are not. The arguments are lists of
 three-element lists containing real coordinates. At least three vertices
 have to be given for each polygon. The function assumes that each polygon
 is actually flat; it doesn't give an error if not. Indeed, it just looks
 at the first three points of each polygon and ignores the rest.";
With[{vecpattern={_?NumericQ,_?NumericQ,_?NumericQ}},
     isParallel[{p1:vecpattern, p2:vecpattern, p3:vecpattern, vecpattern...},
                {q1:vecpattern, q2:vecpattern, q3:vecpattern, vecpattern...}] :=
       Reduce[Exists[a, a!=0 && Cross[p2-p1,p3-p1] == a Cross[q2-q1,q3-q1]]]];
ClearAll[reorderFaces];
reorderFaces::Usage="reorderFaces[vertices,faces] reorders the faces
 in a way that if two faces are parallel each, their indices add up to
 Length[faces]+1. This works only if for each face there's exactly one
 other face that's parallel. The function also works if there are no
 parallel faces at all, in which case the list is returned unchanged. The
 argument vertices contains a list of points in three dimensions for the
 vertices, the faces is a list containing the lists of the indices in
 vertices of the vertices of the face. Apart from pattern matching, no
 error checking is done.";
reorderFaces[vertices:{{_?NumericQ, _?NumericQ, _?NumericQ}..},
             faces:{{_Integer..}..}] :=
  Join@@MapAt[Reverse,
              Transpose@Gather[faces,
                               isParallel[vertices[[#]]& /@ #1,
                                          vertices[[#]]& /@ #2]&],
              -1]

Next, let's fix up your FACES definition because Mathematica starts indexing at 1, not 0:

faces=FACES+1;

Now use the function above to reorder the faces accordingly:

reorderedFaces=reorderFaces[POINTS,faces];

Now let's check that the function indeed does what it should, by plotting the resulting polyhedron. For that, we first determine the middle points of the faces:

middlepoints=(Total[POINTS[[#]]&/@#]/Length[#]&)/@reorderedFaces;

Finally, we draw the result (the drawing surely could be improved, especially the front and back labels are not easily distinguished; however by rotating it with the mouse it's indeed not hard to verify that opposing sides always add up to 21):

Graphics3D[{Opacity[0.5], EdgeForm[Black],
            GraphicsComplex[POINTS, Polygon/@faces],
            MapIndexed[Text[First@#2, #1]&, middlepoints]},
           SphericalRegion->True]

score 2 · Answer 3 · answered Jul 19 '14 at 00:35

I would recommend using PolyhedronData.

I suspect that members of the "Isohedron" class of polyhedra are suitable for use as die.

PolyhedronData["Isohedron"]

{"Cube", "DeltoidalHexecontahedron", "DeltoidalIcositetrahedron", {"Dipyramid", 3}, {"Dipyramid", 5}, "DisdyakisDodecahedron", "DisdyakisTriacontahedron", "Dodecahedron", "Icosahedron", "Octahedron", "PentagonalHexecontahedron", "PentagonalIcositetrahedron", "PentakisDodecahedron", "RhombicDodecahedron", "RhombicTriacontahedron", "SmallTriakisOctahedron", "Tetrahedron", "TetrakisHexahedron", "TriakisIcosahedron", "TriakisTetrahedron"}

The "Faces" property gives a GraphicsComplex that is essentially your lists of vertices and faces -- but possibly not with the same ordering.

PolyhedronData["Icosahedron", "Faces"]

The RegionCentroid function can be used to find the centre of each polygon thus:

RegionCentroid /@ Flatten@Normal@PolyhedronData["Icosahedron", "Faces"]

(You can also map Mean on the polygon vertex data.)

I don't think there is a similar function for finding the face normal but it is easy to roll your own:

regionNormal[Polygon[{v1_, v2_, v3_, ___}, ___]] := Cross[v2 - v1, v3 - v1] // Simplify

Now we define a function that reorders the faces such that the normals of faces $i$ and $n-i+1$ are in opposite directions where $n$ is the number of faces.

ClearAll[dieFaceReorder];
dieFaceReorder[p_String] := 
 dieFaceReorder[Flatten@Normal@PolyhedronData[p, "Faces"]]
dieFaceReorder[p : {Polygon[__] ..}] := Join @@ MapAt[Reverse, 
   Transpose[Gather[p, Simplify[regionNormal[#1] == -regionNormal[#2]] &]], -1]

Note that this function seems to fail for certain polyhedra with a large number of faces.

Finally a Manipulate that demonstrates the reordering for "Isohedron" class polyhedra.

Manipulate[
 Module[{faces = Flatten@Normal@PolyhedronData[p, "Faces"], m},
  If[r, faces = dieFaceReorder[faces]];
  Graphics3D[{EdgeForm[Directive[Blue, Thick]], 
    MapIndexed[{FaceForm[
        Texture[Image@
          Rasterize[
           Framed[Style[First[#2], FontFamily -> "Helvetica", 
             FontSize -> 30, FontVariations -> {"Underline" -> True}],
             FrameMargins -> 30]]], None], 
       Append[#1, {VertexTextureCoordinates -> 
          With[{n = Length[First[#1]]}, 
           Table[{Cos[2 \[Pi] i/n], Sin[2 \[Pi] i/n]} + 1/2, {i, 0, 
             n - 1}]]}]} &, faces]}, SphericalRegion -> True, 
   Lighting -> "Neutral", Boxed -> False]], {{p, "Icosahedron", 
   "Polyhedron:"}, 
  SortBy[# -> {#, PolyhedronData[#, "FaceCount"]} & /@ 
    PolyhedronData["Isohedron"], #[[2, -1]] &]}, {{r, False, 
   "Reorder:"}, {True, False}}, SynchronousUpdating -> False]

Isohedron Manipulate

(Most of the code is take up with adding the face numbers -- not entirely successfully!)

RegionCentroid didn't work for me (wasn't defined), and the method broke down. I'm using v10 on a Raspberry Pi. — DrXenocide, Jul 21 '14 at 10:46
@DrXenocide I'm using 10.0 on MacOS. As I said you can use Mean instead of RegionCentroid, e.g. Flatten@Normal@PolyhedronData["Icosahedron", "Faces"] /. Polygon[v_] :> Mean[v]. — MikeLimaOscar, Jul 22 '14 at 12:38

What is the order of faces on a D20? How can I optimize the order of faces on a D-n?

3 Answers3

Linked

Related