Plotting a Sphericon and Bipyramid with 100 faces

Question

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?

Answer 1

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

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

Answer 2

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]

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]

Answer 3

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

---

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