How to draw a dodecahedron with each face modified to a pentagram?
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"]
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
gr = Show[PolyhedronData["Dodecahedron"], Boxed -> False, ImageSize -> 400];
gr2 = gr /. Polygon[x_] :> Polygon[#[[{1, 3, 5, 2, 4}]] & /@ x];
Row[{gr, gr2}]