# Plotting a region with thin cusps in high-definition via RegionPlot

I want a high-definition picture the real solutions $(s_1,s_2,s_3)$ of the system of inequalities

$3 s_1^2 < (s_2 - s_3)^2 + 2 s_1(s_2 + s_3)\\ 3 s_2^2 < (s_1 - s_3)^2 + 2 s_2(s_1 + s_3)\\ 3 s_3^2 < (s_1 - s_2)^2 + 2 s_3(s_1 + s_2)$

such that $s_1+s_2+s_3=1$ and $s_1>0$, $s_2>0$, $s_3>0$. I would also like to emphasize the solutions for which at least two $s_i$'s are equal.

For this, I wrote the following code:

s1 = r/Sqrt[2] - s/Sqrt[6] + 1/3;(*Parametrization of plane s1+s2+s3=1 *)
s2 = -r/Sqrt[2] - s/Sqrt[6] + 1/3;
s3 = 2 s/Sqrt[6] + 1/3;

reg = RegionPlot[6 r (Sqrt[2] + 3 r - 4 Sqrt[3] s) < 1 + 2 Sqrt[6] s + 6 s^2 && 18 r^2 < 1 + 2 Sqrt[6] s + 6 s^2 + 6 r (Sqrt[2] - 4 Sqrt[3] s) && 4 Sqrt[6] s + 30 s^2 < 1 + 18 r^2, {r, -Sqrt[2]/2, Sqrt[2]/2}, {s, -Sqrt[6]/6, Sqrt[6]/3}, PlotStyle -> LightGray, Axes -> False, Frame -> None, PlotPoints -> 500];

boundary = Plot[{Sqrt[3] r + Sqrt[6]/3, -Sqrt[3] r + Sqrt[6]/3, -Sqrt[6]/
6}, {r, -Sqrt[6]/3, Sqrt[6]/3}, AspectRatio -> 1, AxesOrigin -> {0, 0}, Axes -> False, PlotStyle -> {{Black, Dashed}}];

line1 = Plot[{r/Sqrt[3]}, {r, -(1/(10 Sqrt[2])), 1/(2 Sqrt[2])}, AspectRatio -> 1, AxesOrigin -> {0, 0}, Axes -> False, PlotStyle -> {{Black}}];
line2 = Plot[{-(r/Sqrt[3])}, {r, -(1/(2 Sqrt[2])), 1/(10 Sqrt[2])}, AspectRatio -> 1, AxesOrigin -> {0, 0}, Axes -> False, PlotStyle -> {{Black}}];
line3 = ParametricPlot[{0,s}, {s, -(Sqrt[(2/3)]/5) - Sqrt[3/2]/5, -(Sqrt[(2/3)]/5) + Sqrt[3/2]/5}, AspectRatio -> 1, AxesOrigin -> {0, 0}, Axes -> False, PlotStyle -> {{Black}}];
pic = Show[reg, boundary, line1, line2, line3];
Export["pic.pdf", pic];


obtaining the following image:

The region above should have the obvious symmetries, given by rotations of $120^\circ$. However, my plot looks slightly non-symmetric, since the lower cusp seems to "stop" before the top cusps. The cusps go up to the boundary of the outer triangle, but the plots don't quite make justice to that -- unless one adds a thick boundary to the region, which I don't really like (since it is supposed to represent an open set).

Although raising the PlotPoints to 500 rendered it a lot better, it still looks a bit strange when it is zoomed in. I tried raising PlotPoints to more than 500, but it froze my computer and I had to forcefully restart the machine (3 attempts, ranging between 550 and 1000).

I would like to know if there is a better way to make the above plot, that is, something that makes Mathematica draw the cusps more accurately, arriving all the way to the boundary, and such that all of them look the same. Eventually I want to export it as a PDF.

• Instead of using extreme number of PlotPoints increase MaxRecursion option along with a more modest increase in PlotPoints. Commented Aug 30, 2014 at 4:52

Your plot is not symmetric since your plot has an AspectRatio of 1 while it should be 4/3. This also helps the problem with the cusp not going all the way to the boundary.
[...]