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

Question

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.

Answer 1

Edit - forgot to add a necessary link

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"];
   If[Head[dat] === GraphicsComplex, 
    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"];
   If[Head[dat] === GraphicsComplex, 
    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"];
     If[Head[dat] === GraphicsComplex, 
      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"];

      If[Head[dat] === GraphicsComplex, 
       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.

Answer 2

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 *)
       PadRight[face[[;; 3]], {Automatic, 4}, 1]
       ];

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}, 
    With[{dualfaces = mat["AdjacencyLists"]}, 
     Graphics3D@ GraphicsComplex[
       dualcoords, 
       Polygon[Table[sortvertices[dualcoords, coords[[v]], dualfaces[[v]]],
         {v, Length@dualfaces}]]]]]];

The pentagonal trapezohedron:

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

Answer 3

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.

Answer 4

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.