3
$\begingroup$

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

enter image description here

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!

$\endgroup$

closed as off-topic by Yves Klett, Öskå, Dr. belisarius, Mr.Wizard Jan 3 '15 at 16:08

  • The question does not concern the technical computing software Mathematica by Wolfram Research. Please see the help center to find out about the topics that can be asked here.
If this question can be reworded to fit the rules in the help center, please edit the question.

  • 3
    $\begingroup$ The problem is because of the post-processing you are applying to the contour lines. The lowermost "line" is actually two Line primitives which are individually being reflected. $\endgroup$ – Rahul Jan 2 '15 at 12:30
  • $\begingroup$ @Rahul So, how can this be fixed? $\endgroup$ – Vaggelis_Z Jan 2 '15 at 12:31
  • $\begingroup$ I'm not sure. Maybe one of the other solutions in your previous question doesn't have this problem? $\endgroup$ – Rahul Jan 2 '15 at 12:33
  • 1
    $\begingroup$ it would seem easy enough to just draw those arcs, or construct a function that contours properly without the reflection $\endgroup$ – george2079 Jan 2 '15 at 12:40
  • 3
    $\begingroup$ This question appears to be off-topic because it is deals with a problem caused by specific post-processing by the OP and is very localized. $\endgroup$ – Yves Klett Jan 2 '15 at 14:52
12
$\begingroup$

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]

enter image description here

$\endgroup$
5
$\begingroup$

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.

Mathematica graphics

$\endgroup$
4
$\begingroup$

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..'

$\endgroup$
1
$\begingroup$

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.)

$\endgroup$

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