9
$\begingroup$

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]

Mathematica graphics

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.

$\endgroup$
  • $\begingroup$ The polygon is also on Mathworld so I am hoping that it is somewhere in PolyhedronData. $\endgroup$ – Edmund Dec 6 '16 at 14:40
  • $\begingroup$ 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. $\endgroup$ – Jason B. Dec 6 '16 at 14:45
  • $\begingroup$ @JasonB Yeah, that has way too many polygons. I only need the 10. $\endgroup$ – Edmund Dec 6 '16 at 14:53
19
$\begingroup$

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.

$\endgroup$
  • 1
    $\begingroup$ This is an amazing answer. It is a great framework as well. Many thanks. $\endgroup$ – Edmund Dec 12 '16 at 13:53
7
$\begingroup$

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

$\endgroup$
  • $\begingroup$ This is a very useful function. (+1) $\endgroup$ – Edmund Dec 12 '16 at 13:54
  • 1
    $\begingroup$ @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). $\endgroup$ – Michael E2 Dec 12 '16 at 14:22
  • $\begingroup$ That is a great idea. Perhaps you should suggest to WRI. $\endgroup$ – Edmund Dec 12 '16 at 14:51
6
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ That is a good resource. (+1) $\endgroup$ – Edmund Dec 12 '16 at 13:55
1
$\begingroup$

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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.