Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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:

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.

share|improve this question
3  
Instead of using extreme number of PlotPoints increase MaxRecursion option along with a more modest increase in PlotPoints. –  Bob Hanlon Aug 30 at 4:52

1 Answer 1

up vote 7 down vote accepted

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.
I also made your boundary a bit cleaner.

[...]
boundary = Show[Graphics[{Black, Thick, Dashed, Line[#]}] & /@ Permutations[
            {{0, Sqrt[6]/3}, {-(1/Sqrt[2]), -Sqrt[6]/6}, {1/Sqrt[2], -Sqrt[6]/6}}, {2}][[{1, 2, 4}]]];
[...]
pic = Show[boundary, reg, line1, line2, line3, ImageSize -> {480, 360}]

enter image description here

share|improve this answer
    
Thank you!! The best output was obtained combining your suggestions with Bob Hanlon's about MaxRecursion. I ended up using only PlotPoints->80 and MaxRecursion->5 on the RegionPlot, besides the correct AspectRatio, and the picture looks a lot nicer :) –  Renato G Bettiol Aug 30 at 17:15

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.