How to draw a dodecahedron with each face modified to a pentagram?

Question

I'd like to draw a dodecahedron with each face carved on the sides so it becomes a pentagram. I wonder how to start to do this kind of task in the Wolfram Language?

Edit:

The result should still be a completely enclosed polyhedron; i.e., the carved out parts should be connected by newly added faces. I don't want the result to have holes.

Answer 1

Solution from @chuy looks really nice. Although I think that it was a little bit of work around because it's a visualization only, but the defined structure doesn't really represent the carved dodecahedron. Here is my approach of carving a dodecahedron pumpkin into pentagrams.

First we define a function that makes a pentagram from a pentagon.

tau = (2 Sqrt[5])/(5 + Sqrt[5]);
pentagram[pts_] := 
  Riffle[pts, #] &@(pts[[# + 1]]*tau + (1 - tau)*
        pts[[1 + Mod[# + 2, 5]]] & /@ Range[0, 4, 1]);

Then we apply this function to all faces of dodecahedron.

ind = PolyhedronData["Dodecahedron", "FaceIndices"];
vert = PolyhedronData["Dodecahedron", "VertexCoordinates"];
polyVerts = Reverse@*pentagram /@ (vert[[#]] & /@ ind);

Note the Reverse, it doesn't have to be there, since it just changes the orientation of the pentagram, but it's required to avoid weird artifacts while rendering, see more discussion here.

Now we need to create inner faces of our pumpkin.

pairs = Partition[#, 2] &@Riffle[#, #*85/100] &@polyVerts; 

pairs contain the outer face and inner face. The last thing to do is create wedges that will connect inner faces with outer faces.

wedges[face_] := (Permute[#, Cycles[{{4, 3}}]] &@Flatten[#, 1] &@
        face[[1 ;; -1, #, 1 ;; -1]]) & /@ 
     Partition[#, 2, 1] &@(Range[1, 10]~Join~{1});

Now we need to draw all our polygons: faces and wedges:

Graphics3D[
 Join[{EdgeForm[{Black, Thick}],  Orange}, 
  Polygon /@ Join[wedges[#], #] & /@ pairs], Boxed -> False]

Edit: It has been requested to have no holes in the resulting polyhedron. So no more pumpkin carving.

Let's make a list of all added vertices and include the original pentagon vertex indices that produced these additional concave vertices.

pairList[l_, r_] := Partition[#, 2] &@Riffle[#, RotateLeft[#, r]] &@ l;

concVerts[vert_, face_] := 
  Partition[#, 2] &@
   Riffle[Sort /@ pairList[face, 1], 
    vert[[First[#]]]*tau + (1 - tau)*vert[[Last[#]]] & /@ 
     pairList[face, 2]];
concave = Flatten[#, 1] &@(concVerts[vert, #] & /@ ind);

Now we will fill holes with triangles, every triangle has two concave vertices and one original pentagon vertex.

triang[vert_, up_, edge_, 
   conc_] := {vert[[#[[1, up]]]], #[[2]], #[[4]]} &@Flatten[#, 1] &@ 
   Select[concave, #[[1]] == edge &];

edges = PolyhedronData["Dodecahedron", "Edges"];

tri = Flatten[#, 1] &@
   Table[triang[vert, i, edges[[j]], concave], {i, 1, 2}, {j, 1, 
     Length@edges}];
Graphics3D[
 Join[Polygon /@ tri, {EdgeForm[{Black, Thick}],  Orange}, 
  Polygon /@ polyVerts], Boxed -> False]

Full code on Wolfram Cloud

Answer 2

First, I defined dd as follows:

dd = Entity["Polyhedron", "Dodecahedron"]
(* regular dodecahedron *)

Probing the properties of this Entity object, I can extract the vertex coordinates (I used Short here to truncate the output):

dd["VertexCoordinates"]//Short
(* {{-Sqrt[1+2/Sqrt[5]],0,Root[1-20 #1^2+80 #1^4&,3]},<<19>>} *)

Now, I can use the property "FaceIndices" to see which coordinate corresponds to which point in the face of each side.

dd["FaceIndices"]
(* {{15, 10, 9, 14, 1}, {2, 6, 12, 11, 5}, {5, 11, 7, 3, 19}, 
    {11, 12, 8, 16, 7}, {12, 6, 20, 4, 8}, {6, 2, 13, 18, 20}, 
    {2, 5, 19, 17, 13}, {4, 20, 18, 10, 15}, {18, 13, 17, 9, 10}, 
    {17, 19, 3, 14, 9}, {3, 7, 16, 1, 14}, {16, 8, 4, 15, 1}} *)

It turns out that the order given is (not surprisingly) for a pentagon rather than a pentagram...

Graphics3D[Arrow[dd["VertexCoordinates"][[dd["FaceIndices"][[1]]]]]]

But a bit of shuffling can correct that. I used Permute and PermutationCycles.

Finally, I want to close the loop and connect the last vertex to the first one (for each face). To do this, I used BSplineCurve with the option SplineClosed -> True.

All together:

pents = BSplineCurve[Permute[#, PermutationCycles[{1, 3, 5, 2, 4}]], 
     SplineDegree -> 1, 
     SplineClosed -> True] & /@ (Part[dd["VertexCoordinates"], #] & /@ 
     dd["FaceIndices"]);

Graphics3D[{Thick, White, pents, Purple, Opacity[0.75], dd["Faces"]}]

And if desired, rather than using BSplineCurve, you can use Polygon to also get a nice effect:

pents2 = Polygon[
     Permute[#, 
      PermutationCycles[{1, 3, 5, 2, 4}]]] & /@ (Part[
       dd["VertexCoordinates"], #] & /@ dd["FaceIndices"]);

Graphics3D[{Thick, White, pents2}, Background -> Black, 
 Lighting -> "Neutral"]

Answer 3

gr = Show[PolyhedronData["Dodecahedron"], Boxed -> False, ImageSize -> 400];

gr2 = gr /. Polygon[x_] :> Polygon[#[[{1, 3, 5, 2, 4}]] & /@ x];

Row[{gr, gr2}]

Answer 4

This is a bit late, but I only recently learned of the "AdjacentFaceIndices" property in PolyhedronData[], and this is what led me to figure out how to cleanly deal with generating the required triangles.

First, generate the extra pentagram points from the original dodecahedron's vertices:

np = First @ Normal[PolyhedronData["Dodecahedron", "Faces"]] /. Polygon[pts_] :>
     RootReduce[ScalingTransform[ConstantArray[1 - Tan[π/Length[pts]]^2, 3], Mean[pts]] @
                ListCorrelate[{{1}, {1}}/2, pts, 1]];

Notice that I did not use N[]; I wanted to keep the coordinates exact. The appropriate scaling factor was derived through a little bit of trigonometry.

Generate the corresponding indices:

nidx = PolyhedronData["Dodecahedron", "VertexCount"] + Range[Length[Flatten[np, 1]]];

The index arrangement for the star faces can then be generated like this:

fid = MapThread[Riffle, {PolyhedronData["Dodecahedron", "FaceIndices"],
                         Partition[nidx, 5]}];

Now, the hard part. The idea here is to use "AdjacentFaceIndices" to retrieve the corresponding entries in fid, and match them up with entries from "EdgeIndices". Some shuffling should then yield the indices for the triangular faces.

facs = Function[{fi, af}, fi[[#]] & /@ af][ArrayPad[#, {0, 1}, "Periodic"] & /@ fid, 
                PolyhedronData["Dodecahedron", "AdjacentFaceIndices"]];

(* triangle indices *)
tris = Flatten[MapThread[Function[{facs, edg}, 
                                  Through[{Most, Composition[Reverse, Rest]}[
                                          Insert[#[[1]], #[[2, 2]], 2]]] &[
               First[SequenceCases[#, # | Reverse[#] & @ Insert[edg, _, 2]]] & /@ facs]],
               {facs, PolyhedronData["Dodecahedron", "EdgeIndices"]}], 1];

Finally, generate the modified dodecahedron:

dodstar = GraphicsComplex[Join[PolyhedronData["Dodecahedron", "VertexCoordinates"],
                               Flatten[np, 1]], Polygon[Join[fid, tris]]];

Graphics3D[{FaceForm[Opacity[3/4, ColorData[97, 1]], 
                     Directive[Specularity[3/4, 15], ColorData[97, 2]]],
            dodstar}, 
           Boxed -> False, 
           Lighting -> {{"Ambient", Gray},
                        {"Directional", RGBColor[0.15473514, 0.21284718, 0.29811516], 
                         ImageScaled[{0, 2, 2}]},
                        {"Directional", RGBColor[0.15473514, 0.21284718, 0.29811516], 
                         ImageScaled[{2, 2, 2}]},
                        {"Directional", RGBColor[0.15473514, 0.21284718, 0.29811516], 
                         ImageScaled[{2, 0, 2}]}}]

(The use of FaceForm[] was to demonstrate that all the polygons were oriented consistently anticlockwise.)

Answer 5

You can make your own satan-worshiping dodecahedron by using texture. The following is more-or-less based on a Neat Example in the Texture documentation.

First, download your favourite evil pentagram image:

im = Import["http://vignette1.wikia.nocookie.net/sonicfanchara/images/9/9c/\
Goth-pentagram-devil.gif/revision/latest?cb=20131018174814"];

Then work out the vertex coordinates of a pentagon, normalised so that the centre is in the right place (depending on your choice of image you may need to rotate appropriately - here 3 π/2). Use t as a scaling parameter:

(Sqrt[2] Normalize[ImageDimensions[im]] + t {Re@#, Im@#}) & /@
 (E^(I (2 # π + 3 π/2)/5) &@ Range[5]))/2

Now plug all this into a manipulate so that you have some control over how much goat there is in your dodecahedron:

Manipulate[
 Graphics3D[{Texture[im], 
   FaceForm[
    Red], (Append[#1, {VertexTextureCoordinates -> ( ( 
              Sqrt[2] Normalize[ImageDimensions[im]] +t { Re@#,  Im@#}) & /@
              (E^(I (2 # π + 3 π/2)/5) & @ Range[5]))/2}] &) /@ 
    Flatten @ Normal @ PolyhedronData["Dodecahedron", "Faces"] }, 
  Background -> Gray], {t, .2, 1}]

Finally, why not start a metal band? If short of name ideas, let Mathematica decide for you:

"The " <> RandomChoice[WordData[All, "Adjective"]] <> " " <> 
 RandomChoice[WordData[All, "Noun"]]

The petite American Staffordshire terrier

Answer 6

polyhed = PolyhedronData["Dodecahedron", "Polyhedron"];
coords = PolyhedronData["Dodecahedron", "VertexCoordinates"];
lines = Graphics3D[Line[Tuples[coords, 2]]];
Show[polyhed, lines]

This is a bit of a cheat, since it actually draws lines connecting all pairs of points on the dodecahedron (take a look at the lines object I define in the code); it's just that the lines that run inside the dodecahedron are hidden.