Skip to main content

bugs - How to make sure polygon is drawn flat in 3D?


Bug introduced in 8.0 or earlier and fixed in 10.4





I'm working on this SE question about pentagrams on top of dodecahedron for exercising. Both solutions are basically connecting different sets of vertices of existing dodecahedron. They don't really deal with carving. I want to build a new polyhedron having pentagrams as faces.


I started with a 2D Pentagon and calculated vertices of pentagram from existing vertices of pentagon:


 penPts = {Cos[#], Sin[#]} & /@ Range[0, 2 Pi, 2 Pi/5][[1 ;; -2]];

tau = (2 Sqrt[5])/(5 + Sqrt[5]);

Graphics[{Blue, Polygon[penPts], Red, PointSize [0.03],
Point[penPts[[2]]*tau + penPts[[5]]*(1 - tau)], Green,
Line[penPts[[{1, 3}]]], Line[penPts[[{2, 5}]]]}]


Finding


Then I defined a function that takes a list of pentagon vertices and makes a list of pentagram vertices:


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


Graphics[{Red, PointSize [0.03], Point[pentagram[penPts]], Green,
Opacity[0.5], Polygon[pentagram[penPts]]}]


Building 2D pentagram


Since it finds additional vertices by linear combination of existing ones (using tau and (1-tau) as weights) it will work for 3D points as well.


ind = PolyhedronData["Dodecahedron", "FaceIndices"];
vert = PolyhedronData["Dodecahedron", "VertexCoordinates"];
Graphics3D[ Polygon /@ pentagram /@ (vert[[#]] & /@ ind)]

It kinda worked out. The problem is that not all faces are shown as pentagrams, actually only two of them are pentagrams and all other have nasty artifact. See picture. enter image description here


I can see that the only two faces that worked out are parallel to coordinate plane. So my guess is that the calculations were more accurate there. Other faces suffered the fact that the calculated vertices were not actually in one plane.


Question: Is this correct? If so, what can be done to get rid of artifacts (I know I can triangulate them to make unflatness "invisible")?




Answer



A shot in the dark: Reverse the orientation. Hey, it works...but I don't know why...???


Graphics3D[Polygon /@ Reverse@*pentagram /@ (vert[[#]] & /@ ind)]

Mathematica graphics




A guess at what's happening. I'm not sure of the reason why things work correctly when one coordinate is the same for all vertices and do not work when the plane of the polygon is oblique. In the oblique case, the triangulation consists of triangles all based at the first vertex in the polygon. This works when a polygon is convex, but not always for a star.


MeshCells[
DiscretizeGraphics@ Graphics3D@ Polygon@ pentagram@ vert[[First[ind]]], 2]
(*

{Polygon[{1, 9, 10}], Polygon[{3, 1, 2}], Polygon[{4, 1, 3}], Polygon[{5, 1, 4}],
Polygon[{6, 1, 5}], Polygon[{7, 1, 6}], Polygon[{8, 1, 7}], Polygon[{9, 1, 8}]}
*)

The cell indices are the same if Reverse@ is inserted before pentagram.


So when the polygon's vertex list start with a vertex at a convex corner, artifacts are produced; when it starts with a concave corner, the polygon is drawn correctly -- except, as I said, when one coordinate is the same for all vertices.


The behavior can be reproduced in the triangulation algorithm of DiscretizeGraphics:


Graphics3D[{Polygon[#], 
MapIndexed[Text[Style[#2, "Label", Bold, 16], #1] &, #]} &@
RotateLeft@pentagram@vert[[First[ind]]]

]

DiscretizeGraphics@ Graphics3D@ Polygon@ pentagram@ vert[[First[ind]]]
DiscretizeGraphics@ Graphics3D@ Polygon@ Reverse@ pentagram@ vert[[First[ind]]]

Mathematica graphics Mathematica graphics Mathematica graphics


Reversing the order puts vertex 10 first in the list. We can also rotate the list so that an concave corner starts the list.


Graphics3D[{Polygon[#], 
MapIndexed[Text[Style[#2, "Label", Bold, 16], #1] &, #]} &@
RotateLeft@ pentagram@ vert[[First[ind]]]

]

Mathematica graphics


Comments

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],