# How to construct a 3D 10-sided Die (Pentagonal trapezohedron) and Spin to a face?

The Creating 3D dice question has answers for constructing a 6-sided die with images faces. I need to construct a 10-sided die with numbered faces. My first thought was to find 10-side polyhedra using PolyhedronData.

PolyhedronData[10]

{{"Antiprism", 4}, "AugmentedPentagonalPrism", "AugmentedTridiminishedIcosahedron",
{"Dipyramid", 5}, {"Prism", 8}, "SquareCupola"}


Of these {"Dipyramid", 5} is the closest to the required shape of a Pentagonal trapezohedron.

Graphics3D[{EdgeForm[Gray], Red, PolyhedronData[{"Dipyramid", 5}, "Faces"]},
BoxRatios -> {1, 1, 1}, Boxed -> False]


Is the Pentagonal trapezohedron in PolyhedronData? If so how do I find it? If not, how do I go about constructing it? Might it be in LatticeData in some form?

For the numbers I believe I need to isolate the faces and use Texture from a Rasterized text of the numbers. However, I am not certain how to isolate the faces. This depends on the format of the polygon. Perhaps once I have the polygon format this will not be an issue.

Finally I need to spin the dice to a certain numbered face. I think I can figure this out with normals to the faces and a rotation matrix or maybe ViewPoint of Graphics3D. However, suggestions are also welcome.

For context, this provide a visual to a random process.

• The polygon is also on Mathworld so I am hoping that it is somewhere in PolyhedronData. Commented Dec 6, 2016 at 14:40
• There isn't a 3D graphics return from Alpha on this, so I don't know if it is in the knowledge base. You could grab this d10 die model (you have to create a free account); it looks great but the mesh region imported has 5.6k polygons. Commented Dec 6, 2016 at 14:45
• @JasonB Yeah, that has way too many polygons. I only need the 10. Commented Dec 6, 2016 at 14:53

Coincidentally I had a little personal project trying to make a good dice roller in Mathematica a while back. Here's some of my code (note: this was before I learned a lot of efficiency techniques so it's not quick but it does make a fairly decent animation). No apologies for the awful colour scheme though...

## Constructing the dice object

Makes a texture for the sides

plt[num_] :=
ReliefPlot[
Table[i + Sin[i^2 + j^2], {i, -4, 4, .03}, {j, -4, 4, .03}],
ColorFunction -> "SunsetColors",
Epilog ->
Inset[Text[Style[ToString[num], Bold, 40, Underlined]], {Center,
Center}, {Center, Center}]];


Creates a single dice face

makeFace[num_] := {Texture[Image@plt[num]],
Append[#1, {VertexTextureCoordinates ->
With[{n = Length[First[#1]]},
Table[1/2 {Cos[2 \[Pi] i/n], Sin[2 \[Pi] i/n]} + {1/2,
1/2}, {i, 0, n - 1}]]}] &@
Polygon[dat[[1, dat[[2, 1, num]]]]]}


Makes a faces sided dice by constructing each individual GraphicsComplex

dice[faces_] := Quiet[Module[{shape},
shape =
Switch[faces, 4, "Tetrahedron", 6, "Cube", 8, "Octahedron",
10, {"Dipyramid", 5}, 12, "Dodecahedron", 20, "Icosahedron", _,
Missing["InvalidDice"]];
dat = PolyhedronData[shape, "Faces"];
Graphics3D[{makeFace /@ Range[faces]}, Lighting -> "Neutral",
Boxed -> False], shape]]]


Tesing an 8 sided dice:

dice[8]


## Rolling the graphic

Boundaries of the dice (this could be improved with BoundingRegion)

minz = Min[dat[[1, All, 3]]];
minx = Min[dat[[1, All, 1]]];
miny = Min[dat[[1, All, 2]]];
maxx = Max[dat[[1, All, 1]]];
maxy = Max[dat[[1, All, 2]]];


Redefine dice to be able to change viewpoint

dice[faces_, opts___] := Quiet[Module[{shape},
shape =
Switch[faces, 4, "Tetrahedron", 6, "Cube", 8, "Octahedron",
10, {"Dipyramid", 5}, 12, "Dodecahedron", 20, "Icosahedron", _,
Missing["InvalidDice"]];
dat = PolyhedronData[shape, "Faces"];
Graphics3D[{makeFace /@ Range[faces]}, Boxed -> False,
SphericalRegion -> True, opts], shape]]]


At this point I just copied out a bunch of nice viewpoints for each graphic, but you could probably automate this. I'll attach the definition for the view locations but it's of the form view = <| numberoffaces -> <|sidenumber -> viewpoint, sidenumber2 -> viewpoint2|>...|> for each sidedness of dice.

Here is the data (pastebin link)

Now randomly choose a roll:

random[faces_] :=
dice[faces, ViewPoint -> view[faces, RandomInteger[{1, faces}]]]


Add a bounce in (oh wow, I forgot how far I went with this...)

bn[n_] := Abs[Sin[n/(2 Pi)]]*n/30;
roll[faces_, opts___] := Module[{graphic},
graphic = random[faces];
Animate[
Graphics3D[{Rotate[graphic[[1]], n Degree, {1, 1, 1}],
Polygon[{{{minx - 2, miny - 2, minz + bn[n]}, {maxx + 2,
miny - 2, minz + bn[n]}, {maxx + 2, maxy + 2,
minz + bn[n]}, {minx - 2, maxy + 2, minz + bn[n]}}}]},
Sequence @@ graphic[[2 ;;]], opts], {n, -120, 0},
AnimationRepetitions -> 1, AnimationRate -> 60,
AppearanceElements -> None]]


The bounce is like this:

## Putting it together

A single roll:

roll[faces_] := Module[{graphic, i},

makeFace[
num_] := {Texture[
Image@Graphics[
Text[Style[ToString[num], Bold, 30, Underlined]]]],
Append[#1, {VertexTextureCoordinates ->
With[{n = Length[First[#1]]},
Table[1/2 {Cos[2 \[Pi] i/n], Sin[2 \[Pi] i/n]} + {1/2,
1/2}, {i, 0, n - 1}]]}] &@
Polygon[dat[[1, dat[[2, 1, num]]]]]};

dice[n_, opts___] := Quiet[Module[{shape},
shape =
Switch[n, 4, "Tetrahedron", 6, "Cube", 8, "Octahedron",
10, {"Dipyramid", 5}, 12, "Dodecahedron", 20, "Icosahedron", _,
Missing["InvalidDice"]];
dat = PolyhedronData[shape, "Faces"];
Graphics3D[{makeFace /@ Range[n]}, Lighting -> "Neutral",
Boxed -> False, SphericalRegion -> True, opts], shape]]];

random[n_] :=
dice[n, ViewPoint -> view[n, i = RandomInteger[{1, n}]]];

graphic = random[faces];

{Animate[
Graphics3D[Rotate[graphic[[1]], n Degree, {1, 1, 1}],
Sequence @@ graphic[[2 ;;]]], {n, -120, 0},
AnimationRepetitions -> 1, AnimationRate -> 60,
AppearanceElements -> None], i}]


Trying that out:

roll[8]


The full application (you need to evaluate the view definition in the link):

CreateDialog[Pane[DynamicModule[{}, Row[{Grid[{
{"Select dice: ",
Row[{"d", PopupMenu[Dynamic[num], {4, 6, 8, 10, 12, 20}]}]},
{Button["Roll!", out = roll[num];
AppendTo[history, {Text["d" <> ToString[num]], out[[2]]}]],
SpanFromLeft},
{Dynamic[out[[1]]], SpanFromLeft}}],
Column[{Button["Reset history?",
history = {{Style["History", "Text", Bold, 14],
SpanFromLeft}};],
Pane[Dynamic[Grid[history]], {200, 400}, Scrollbars -> True],
Dynamic[If[Length[history] > 1,
Text["Mean: " <> ToString[N@Mean[history[[2 ;;, 2]]]]],
""]]}]}],

Alignment -> Left,
BaseStyle -> {"Text", 14},
Initialization :> (history = {{Style["History", "Text", Bold, 14],
SpanFromLeft}};
roll[faces_] := Module[{graphic, i},

makeFace[
num_] := {Texture[
Image@Graphics[
Text[Style[ToString[num], Bold, 30, Underlined]]]],
Append[#1, {VertexTextureCoordinates ->
With[{n = Length[First[#1]]},

Table[1/2 {Cos[2 \[Pi] i/n], Sin[2 \[Pi] i/n]} + {1/2,
1/2}, {i, 0, n - 1}]]}] &@
Polygon[dat[[1, dat[[2, 1, num]]]]]};

dice[n_, opts___] := Quiet[Module[{shape},

shape = Switch[n, 4, "Tetrahedron", 6, "Cube", 8,
"Octahedron", 10, {"Dipyramid", 5}, 12, "Dodecahedron",
20, "Icosahedron", _, Missing["InvalidDice"]];
dat = PolyhedronData[shape, "Faces"];

Graphics3D[{makeFace /@ Range[n]}, Lighting -> "Neutral",
Boxed -> False, SphericalRegion -> True, opts], shape]]];

random[n_] :=
dice[n, ViewPoint -> view[n, i = RandomInteger[{1, n}]]];

graphic = random[faces];

{Animate[
Graphics3D[Rotate[graphic[[1]], n Degree, {1, 1, 1}],
Sequence @@ graphic[[2 ;;]]], {n, -120, 0},
AnimationRepetitions -> 1, AnimationRate -> 60,
AppearanceElements -> None], i}
];

out = roll[8]
)]]]


Phew! Didn't think I'd be posting that but there you go, maybe there are some bits you might use.

• This is an amazing answer. It is a great framework as well. Many thanks. Commented Dec 12, 2016 at 13:53

The pentagonal trapezohedron is the dual of the pentagonal antiprism:

PolyhedronData[{"Antiprism", 5}]


Unfortunately, the dual is not in PolyhedronData:

PolyhedronData[{"Antiprism", 5}, "Dual"]
(*  Missing["NotApplicable"]  *)


So here's a function to compute the dual of a polyhedron. (It's an adaptation of dual for meshes in my answer to create an (almost) hexagonal mesh on an ellipsoid to polyhedra that have duals.)

ClearAll[dual, sortvertices, reciprocate];

sortvertices[coords_, normal_, face_] :=
With[{proj = DeleteCases[
Orthogonalize[Join[{normal}, N@IdentityMatrix[3]]], {0., 0., 0.}][[2 ;; 3]]},
SortBy[face, ArcTan @@ (proj.coords[[#]]) &]];

reciprocate[face_?MatrixQ, r_: 1] /; Length[face] >= 3 :=
r^2 {1, -1, 1} Most[#]/Last[#] &@ Reverse@ Last@ Minors@ Join[
{{0, 0, 0, 0}},(* dummy row *)
];

dual[polyhedron : Graphics3D@GraphicsComplex[coords_, Polygon[faces_]]] :=
With[{nvertices = Max@faces, nfaces = Length@faces},
With[{mat = SparseArray@ Flatten@ Table[{v, f} -> 1, {f, nfaces}, {v, faces[[f]]}],
dualcoords = reciprocate[coords[[#]]] & /@ faces},
Graphics3D@ GraphicsComplex[
dualcoords,
Polygon[Table[sortvertices[dualcoords, coords[[v]], dualfaces[[v]]],
{v, Length@dualfaces}]]]]]];


The pentagonal trapezohedron:

dual@ PolyhedronData[{"Antiprism", 5}]


• This is a very useful function. (+1) Commented Dec 12, 2016 at 13:54
• @Edmund Thanks. Some of these *Data[] systems have standard operations that I wish such utilities were included in them, like PolyhedronData["Dualize"][poly] etc. (instead of relying on the data being present or not). Commented Dec 12, 2016 at 14:22
• That is a great idea. Perhaps you should suggest to WRI. Commented Dec 12, 2016 at 14:51

Here's a start with defining your polygons. This page has coordinates for many different shapes. I'm not familiar with the format, you may be able to import this coordinates file directly. But a little copy/paste, change indices to start at 1, and you have this

verts [C0_,C1_,C2_]:= {
{0,C0,C1},{0,C0,-C1},
{0,-C0,C1},{0,-C0,-C1},
{1/2,1/2,1/2},{1/2,1/2,-(1/2)},
{-(1/2),-(1/2),1/2},{-(1/2),-(1/2),-(1/2)},
{C2,-C1,0},{-C2,C1,0},
{C0,C1,0},{-C0,-C1,0}};
faces={{9,3,7,12},{9,12,8,4},
{9,4,2,6},{9,6,11,5},
{9,5,1,3},{10,1,5,11},
{10,11,6,2},{10,2,4,8},
{10,8,12,7},{10,7,3,1}};
Graphics3D@GraphicsComplex[
verts[(Sqrt[5]-1)/4,(Sqrt[5]+1)/4,(Sqrt[5]+3)/4],
Polygon/@faces]


Now all you need to do is apply textures.

• That is a good resource. (+1) Commented Dec 12, 2016 at 13:55

Just posting a streamlined solution for the 6-sided case from the information I gained from @lowriniak very insightful post. It is easily expanded to other die.

It makes use of the normals to the faces for the view points which replaces the need for the predefined view association. Uses one Graphics3D with Dynamic changing ViewPoint and Rotate. Some manual adjustment of the VertexTextureCoordinates were made for this 6-sided case to have them upright when the animation completes.

dsDice = With[{faces = PolyhedronData["Cube", "Faces"]},
With[{vertices = faces[[1, faces[[2, 1, #]]]]},
<|
"Face" -> {
Texture[Image@
Graphics[Text[Style[ToString[#], Bold, 100, Underlined]]]],
Polygon[vertices,
VertexTextureCoordinates ->
RotateLeft[{{0, 0}, {1, 0}, {1, 1}, {0, 1}},
Switch[#, 1 | 2, 2, 5, 1, _, 3]]]
},
"NormalVector" ->
Subtract @@ vertices[[{1, 2}]]\[Cross]Subtract @@ vertices[[{1, 3}]]
|>
] & /@ Range[6]
] // Dataset;


dsDice holds the faces and their normal vectors.

roll[] :=
With[{event = RandomInteger[{1, 6}], spin = RandomChoice[{-1, 1}, 3]},
{
DynamicModule[{t = 1},
Dynamic[
t = Max[0, t - 0.03];
Graphics3D[
Rotate[Normal@dsDice[All, "Face"], t (5 \[Pi])/3, spin],
ViewPoint -> Normal@dsDice[event, "NormalVector"],
Lighting -> {{"Ambient", White}}, Boxed -> False,
RotationAction -> "Clip"]
]]
,
event
}
]


roll returns the animation that runs immediately and the face value of the roll. The animation and RandomInteger call can be separated if the animation needs to be delayed.

Thanks again for all the answers. I'll be implementing the 10-sided case shortly.