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

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]

8 sided dice object

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:

Dice bounce shape

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]

Rolling a d8

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]
)]]]

Dice roller

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


The pentagonal trapezohedron is the dual of the pentagonal antiprism:

PolyhedronData[{"Antiprism", 5}]

Mathematica graphics

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}]

Mathematica graphics


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]

Mathematica graphics

Now all you need to do is apply textures.