2
$\begingroup$

I would like to plot a convex polyhedron with 100 faces, which could be used as a die. My first attempt was asking for Conway's Hecatohedron. Unfortunately, it can not be used as a die.

Now, there are two objects which would satisfy what I need, and I would like to know how to plot them in Mathematica:

1) A 100 faces Sphericon. A picture can be seen here.

2) A Bipyramid with 100 faces.

And a follow-up question: Are there other objects which could represent 100-sided dice? Maybe a generalisation of Archimedean solids?

$\endgroup$
1
  • 2
    $\begingroup$ Although you can use these as die, they are not fair die. In order to be fair the dice should be both orthohedral and equispherical. If someone were to spin this die with either point down they might influence the roll. A fair die gives a statistically linear distribution. There is a fair die shape with 120 sides, but not 100. You might cut 100 facets on a sphere? $\endgroup$
    – wilsotc
    May 26, 2014 at 0:05

3 Answers 3

7
$\begingroup$
Graphics3D[
 {GraphicsComplex[
   Join[{Cos[#], Sin[#], 0} & /@ Range[0, 2 Pi, 2 Pi/(50)], {{0, 0, 1}}],
   {GeometricTransformation[Polygon[{##, 52} & @@@ Partition[Range[51], 2, 1]],
                            {IdentityMatrix[3], ScalingTransform[{1, 1, -1}]}]
   }]}]

enter image description here

Graphics3D[{GraphicsComplex[
   Join[{Cos[#], Sin[#], 0} & /@ Range[0, Pi, Pi/(25)], {{0, 0, 1}}], 
   {
    {#, Rotate[Rotate[#, 180 °, {0, 0, 1}], 90 °, {0, 1, 0}]} &[
         GeometricTransformation[Polygon[{##, 27} & @@@ Partition[Range[26], 2, 1]],  
                                 {IdentityMatrix[3], ScalingTransform[{1, 1, -1}]}]
     ]
    }]}]

enter image description here

$\endgroup$
5
  • $\begingroup$ Very nice, thank you. Do you also know how to generate a sphericon? $\endgroup$ May 25, 2014 at 8:45
  • $\begingroup$ @Mario Is this what you are after? $\endgroup$
    – Kuba
    May 25, 2014 at 8:56
  • $\begingroup$ Yes, wow. Beautiful! Thanks alot. Now i need to understand it :) $\endgroup$ May 25, 2014 at 9:06
  • $\begingroup$ @Mario Feel free to ask if you face any problems. Also, it is good to hold on about a day with an accept, better answers may appear, let's do not discourage others. You can still upvote the anser (+1) if you like it. ;) $\endgroup$
    – Kuba
    May 25, 2014 at 9:09
  • 1
    $\begingroup$ @Kuba See here for the follow-up of your code :) Thanks alot again! $\endgroup$ Jul 13, 2014 at 12:43
6
$\begingroup$
styles = {MeshFunctions -> {#4/(Pi) &}, Mesh -> {Range[-1, 1, .05]}, 
         BoundaryStyle -> Black,  ImageSize -> 600, Boxed -> False, Axes -> False, 
     PlotStyle ->  Directive[Orange, Opacity[0.9], Specularity[White, 30]]};

ParametricPlot3D[{{v Sin[u], v Cos[u], v - 1}, {v Sin[u], v Cos[u], 1 - v}},
    {u, -Pi, Pi}, {v, 0, 1}, Evaluate@styles]

enter image description here

ParametricPlot3D[{ConditionalExpression[{{v Sin[u], v Cos[u],v - 1},
                    {v Sin[u], v Cos[u], 1 - v}}, u <= 0],
                   ConditionalExpression[{{v Sin[u], v - 1, v Cos[u]}, 
                    {v Sin[u], 1 - v, v Cos[u]}}, u > 0]}, 
       {u, -Pi, Pi}, {v, 0, 1}, Evaluate@styles]

enter image description here

$\endgroup$
0
2
$\begingroup$

Here is some code for generating a bipyramid:

With[{n = 100}, 
     Graphics3D[GraphicsComplex[Join[{{0, 0, 1}}, 
                                     PadRight[CirclePoints[n/2], {Automatic, 3}],
                                     {{0, 0, -1}}], 
                                With[{ed = Partition[Range[2, n/2 + 1], 2, 1, 1]},
                                     {Polygon[Join[PadLeft[ed, {Automatic, 3}, 1], 
                                                   PadRight[Reverse[ed, 2],
                                                            {Automatic, 3}, n/2 + 2]]]}]], 
                Boxed -> False]]

bipyramid


Making a sphericon is a little trickier. A slight modification of the code above produces the following:

With[{n = 100},
     Block[{h = n/2, q = n/4, h1, h2, i1, i2},
           {h1, h2} = TakeDrop[PadRight[CirclePoints[{1, 0}, h], {Automatic, 3}], q + 1];
           h2 = Join[{{0, 0, 1}}, RotationTransform[π/2, {0, 1, 0}][h2], {{0, 0, -1}}];
           {i1, i2} = TakeDrop[Range[h + 2], q + 1];
           Graphics3D[GraphicsComplex[Join[h1, h2],
                                     {Polygon[Join[
                                      PadRight[Partition[i1, 2, 1], {Automatic, 3}, q + 2], 
                                      PadLeft[Reverse[Partition[i1, 2, 1], 2],
                                              {Automatic, 3}, h + 2],
                                      PadRight[Partition[i2, 2, 1], {Automatic, 3}, 1], 
                                      PadLeft[Reverse[Partition[i2, 2, 1], 2],
                                              {Automatic, 3}, q + 1]]]}],
                      Boxed -> False]]]

sphericon

$\endgroup$
1
  • $\begingroup$ Wow that was quick :D thanks. $\endgroup$ May 17, 2020 at 5:38

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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