Finding the two points on a heart-shaped curve which have maximal distance between them

You can use FindMaximum to numerically maximize the distance (squared) between two arbitrary points $(x_1, y_1)$ and $(x_2, y_2)$, subject to the constraint that both points lie on the curve:

soln = FindMaximum[{(x1 - x2)^2 + (y1 - y2)^2, 
                    {((1.2 x1)^2 + (1.4 y1)^2 - 1)^3 - (1.3 x1)^2 y1^3 == 0,  
                     ((1.2 x2)^2 + (1.4 y2)^2 - 1)^3 - (1.3 x2)^2 y2^3 == 0}},
                   {{x1, 0.33}, {y1, 0.82}, {x2, -0.9}, {y2, 0.3}}]
ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}, AspectRatio -> Automatic, Epilog -> {PointSize[Large], Red, Point[{{x1, y1}, {x2, y2}} /. soln[[2]]]}]

(* {3.21208, {x1 -> 0.896114, y1 -> 0.282435, x2 -> -0.896114, y2 -> 0.282435}} *)

enter image description here

I had to play around with the starting value quite a lot to arrive at this result, though. FindMaximum tends to get "stuck" at the points where $x = 0$ or $y = 0$; I presume this has something to do with the form of the constraint curves at these points.

EDIT: Note that the value of 3.21208 is the square of the distance between these points. The actual distance would therefore be 1.79223, which is in good agreement with the distance that @Xavier extracted from the plot data.


Making a post out of my comment as suggested. Note that the first part of what follows answers a (restricted) interpretation of a previous version of the question. It only concerns the computation of the maximum distance of a heart-shaped curve, and not the two points that satisfy it. The second part of this answer uses J.M.'s proposition.

The function DistanceMatrix introduced in 10.3 offers an alternative approach,

DistanceMatrix[{$u_1$, $u_2$, $\dots$}, {$v_1$, $v_2$, $\dots$}] gives the matrix of distances between each pair of elements $u_i$, $v_j$.

We simply need to extract the points from ContourPlot and feed DistanceMatrix with them:

points = ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, 
                     {x, -1.5, 1.5}, {y, -3/2, 3/2}][[1, 1]];

Max@ DistanceMatrix[points, points]

(* 1.79212 *)

One can get a more accurate evaluation of the maximum distance by modifying the value of the option MaxRecursion for ContourPlot:

With[{points = ContourPlot[
         ((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, 
         {x, -1.5, 1.5}, {y, -3/2, 3/2}, MaxRecursion -> 6][[1, 1]]},

     Max@DistanceMatrix[points, points]]

(* 1.79223 *)

which brings us to the same value as the one obtained by Michael Seifert in his answer, but at the expense of performance. A RepeatedTiming, from the construction of points to the final output, gives respectively 0.0537 and 1.29 seconds (against the 0.0247 seconds of Michael's FindMaximum).

The proposition of J.M. posted in a comment is probably the way to go, as it avoids searching for the appropriate starting values of FindMaximum, while performing similarly as the latter,

NMaximize[{(x1 - x2)^2 + (y1 - y2)^2, 
            {((1.2 x1)^2 + (1.4 y1)^2 - 1)^3 - (1.3 x1)^2 y1^3 == 0,
             ((1.2 x2)^2 + (1.4 y2)^2 - 1)^3 - (1.3 x2)^2 y2^3 == 0}
          }, {x1, x2, y1, y2}]

(* {3.21208, {x1 -> -0.896114, x2 -> 0.896114, y1 -> 0.282435, y2 -> 0.282435}} *)

Here is an approach that turns the graphics into a region and with the help of NArgMax we get the desired points quite easily (this method is approximate, but a good one):

cp = ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 
     0, {x, -1.5, 1.5}, {y, -3/2, 3/2}, AspectRatio -> Automatic, MaxRecursion -> 6];

Now we turn the plot into a region:

reg = DiscretizeGraphics @ cp;

Finally, get the points of interest:

NArgMax[Norm[{x, y} - {u, v}], {{x, y} ∈ reg, {u, v} ∈ reg}] // Quiet

{0.896113, 0.282458, -0.896113, 0.282458}

Note: The following approach will not work in Mathematica 10.4 but works in 10.3.1

Also, one can use DiscretizeRegion to achieve the same thing without plotting the curve:

imp = ImplicitRegion[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, 
                     {{x, -1.2, 1.2}, {y, -1.2, 1.2}}];

dreg = DiscretizeRegion[imp, MaxCellMeasure -> 0.0001];

Then, as before:

NArgMax[Norm[{x, y} - {u, v}], {{x, y} ∈ dreg, {u, v} ∈ dreg}] // Quiet

This approach gives a better approximation because we can control the "fineness" of the discretization with MaxCellMeasure.

{0.896114, 0.282435, -0.896114, 0.282435}

Tags:

Computational Geometry

Recent Posts