Problem with ContourPlot [Not smooth curve] [closed]

Question

Here is my code

V[x_, y_] := ω^2/2*(x^2 + y^2) - \[Epsilon]*(-(x^6/6) + 5/2*x^4*y^2 - 5/2*x^2*y^4 + y^6/6);
f[x_, y_] := x^2 + y^2;

ω = 1; \[Epsilon] = 1;
h = 1.1;
rad = 1.8*h;
xmin = 2;

P00 = Show[{{Normal@
  ContourPlot[f[x, y] == rad, {x, -xmin, xmin}, {y, -xmin, xmin}, 
   ContourStyle -> {Red, Dashed, Thick}, PlotPoints -> 200, 
   PerformanceGoal :> "Quality", 
   RegionFunction -> (V[#1, #2] < h &), MaxRecursion -> 4] /. 
 Line[{p1_, pp___, p2_}] :> 
  GeometricTransformation[Line[{p1, pp, p2}], 
   ReflectionTransform[Cross[p2 - p1], p2]], 
 ContourPlot[V[x, y] == h, {x, -xmin, xmin}, {y, -xmin, xmin}, 
 ContourStyle -> {Black, Thickness[0.007]}, PlotPoints -> 200, 
 PerformanceGoal :> "Quality"]}}, FrameLabel -> {"x", "y"}, 
 RotateLabel -> False, 
 FrameStyle -> Directive[FontSize -> 20, FontFamily -> "Helvetica"], 
 PlotRange -> All, PlotRangePadding -> None, ImageSize -> 550]

and this is the corresponding output

As you can see, there is an unwanted angle in the red dashed line. It should be smooth as the rest five since the function is symmetrical. I tried to increase the PlotPoints and the MaxRecursion but the problem remains.

Any suggestions on how to fix this?

Many thanks in advance!

Answer 1

The problem occurs because

z = Normal@ContourPlot[f[x, y] == rad, {x, -xmin, xmin}, {y, -xmin, xmin}, 
   ContourStyle -> {Red, Dashed, Thick}, PlotPoints -> 200, 
   PerformanceGoal :> "Quality", RegionFunction -> (V[#1, #2] < h &), MaxRecursion -> 4]

contains seven Lines, not six (because the Line representing the original dashed circle has a beginning and an end). This can be seen from

Position[z, Line[y__], Infinity]
{* {{1, 1, 3, 1, 2}, {1, 1, 3, 1, 3}, {1, 1, 3, 1, 4}, {1, 1, 3, 1, 
  5}, {1, 1, 3, 1, 6}, {1, 1, 3, 1, 7}, {1, 1, 3, 1, 8}} *}

From

Table[Length[z[[1, 1, 3, 1, i, 1]]], {i, 2, 8}]
{* {248, 743, 769, 687, 738, 722, 448} *}

it is evident that the first and last of the Lines must be merged, and the last Line then deleted

z[[1, 1, 3, 1, 2, 1]] = Join[z[[1, 1, 3, 1, 8, 1]], z[[1, 1, 3, 1, 2, 1]]]; 
z = Delete[z, {1, 1, 3, 1, 8}]

With z thus modified,

Show[{{z /. Line[{p1_, pp___, p2_}] :> GeometricTransformation[Line[{p1, pp, p2}], 
   ReflectionTransform[Cross[p2 - p1], p2]], 
   ContourPlot[V[x, y] == h, {x, -xmin, xmin}, {y, -xmin, xmin}, 
    ContourStyle -> {Black, Thickness[0.007]}, PlotPoints -> 200, 
    PerformanceGoal :> "Quality"]}}, FrameLabel -> {"x", "y"}, RotateLabel -> False, 
 FrameStyle -> Directive[FontSize -> 20, FontFamily -> "Helvetica"], 
 PlotRange -> All, PlotRangePadding -> None]

Answer 2

Using ContourPlot for such a simple thing as a circle is like, well, inviting the guys from CSI to find out who has eaten your apple. A circle has a very simple parametric form and you should rather use ParametricPlot for this:

pm = Normal[
   ParametricPlot[rad {Cos[phi], Sin[phi]}, {phi, 0, 2 Pi}, 
    PlotStyle -> {Red, Dashed, Thick}, 
    RegionFunction -> (V[#1, #2] < h &)]] /. 
  Line[{p1_, pp___, p2_}] :> 
   GeometricTransformation[Line[{p1, pp, p2}], 
    ReflectionTransform[Cross[p2 - p1], p2]]

It is by magnitudes faster and it really only draws the lines required. Therefore, your Line replacement will instantly work.

Answer 3

Here is another approach, contour just one of the segments, reflect it then make 6 rotated copies of the arc..

 P00 = Show[{{Normal@
     ContourPlot[f[x, y] == rad, {x, -xmin, xmin}, {y, -xmin, xmin}, 
     ContourStyle -> {Red, Dashed, Thick}, PlotPoints -> 200, 
     PerformanceGoal :> "Quality", 
     RegionFunction -> (V[#1, #2] < h && 
                        Abs[ArcTan[#2, #1] ] < Pi/6 &),
           MaxRecursion -> 4] /. 
     Line[{p1_, pp___, p2_}] :> 
       GeometricTransformation[Line[{p1, pp, p2}], 
        Table[ Composition[RotationTransform[i Pi/3], 
                           ReflectionTransform[Cross[p2 - p1], p2]], {i, 0, 5}]] , 
     ContourPlot[V[x, y] == h, {x, -xmin, xmin}, {y, -xmin, xmin}, 
       ContourStyle -> {Black, Thickness[0.007]}, PlotPoints -> 200, 
       PerformanceGoal :> "Quality"]}}, FrameLabel -> {"x", "y"}, 
       RotateLabel -> False, 
       FrameStyle -> Directive[FontSize -> 20, FontFamily -> "Helvetica"], 
       PlotRange -> All, PlotRangePadding -> None, ImageSize -> 550]

this of course relies on a bit of luck that the segment we picked is a smooth one..'

Answer 4

Approach from my comment, getting rid of the reflection and directly contour plotting the outer circles. This is actually slower, but somehow a more satisfying approach..

V[x_, y_] := ω^2/2*(x^2 + y^2) - \[Epsilon]*(-(x^6/6) + 5/2*x^4*y^2 - 5/2*x^2*y^4 + y^6/6);
f[x_, y_] := x^2 + y^2;

ω = 1; \[Epsilon] = 1;
h = 1.1;
rad = 1.8*h;
xmin = 2;

pint = {x, y} /. NSolve[ V[x, y] == h && f[x, y] == rad , {x, y}];
pp = First@SortBy[pint, Abs[#[[1]]] &];
z = y /. NSolve[ pp[[1]]^2 + (y + pp[[2]])^2 == rad && y^2 > rad] // First;
cp  = -z Table[  {Sin[n Pi/3], Cos[n Pi/3]} , {n, 1, 6}];
P00 = Show[{{Normal@
    ContourPlot[
       Evaluate[((x - #[[1]])^2 + (y - #[[2]])^2 == rad) & /@ cp],
         {x, -xmin, xmin}, {y, -xmin, xmin}, 
       ContourStyle -> {{Red, Dashed, Thick}}, PlotPoints -> 200, 
       PerformanceGoal :> "Quality", 
       RegionFunction -> (V[#1, #2] < h &), MaxRecursion -> 4], 
    ContourPlot[V[x, y] == h, {x, -xmin, xmin}, {y, -xmin, xmin}, 
      ContourStyle -> {Black, Thickness[0.007]}, PlotPoints -> 200, 
      PerformanceGoal :> "Quality"]}}, FrameLabel -> {"x", "y"}, 
      RotateLabel -> False, 
      FrameStyle -> Directive[FontSize -> 20, FontFamily -> "Helvetica"], 
      PlotRange -> All, PlotRangePadding -> None, ImageSize -> 550]

(the result is identical to @bbgodfry's result so I wont bother posting the graphic.)