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

The question originates from Max & min distance between two moving points. I think it can be solved easily because of the function is a parametic function. My heat-shaped curve is given by

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]


So how do I find two points on this curve that have maximal distance between them?

• This could be a possibility : mat = 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[mat, mat] (returns 1.79212).
– user31159
Mar 8 '16 at 21:13
• Thanks your amaze function of DistanceMatrix.But this method by mat[[1,1]] lead to a rough result?
– yode
Mar 8 '16 at 21:23
• @Xavier: You should write that up as an answer. It's pretty slick. Mar 8 '16 at 21:49

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}} *)


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.

• When you run re = ImplicitRegion[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, y}]; soln = FindMaximum[{EuclideanDistance[{x1, y1}, {y1, y2}], {{x1, y1} \[Element] re, {x2, y2} \[Element] re}}, {{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]]]}].you will get another result.
– yode
Mar 8 '16 at 21:37
• @yode: As I noted, the FindMaximum algorithm tends to get "stuck" on points with $x = 0$ or $y = 0$, for reasons I'm not entirely clear on. This is one such example. Note that FindMaximum returns an error message for your code (due to poor convergence to a maximum), but does not for mine. (Also, you have an error in your expression: it should be EuclideanDistance[{x1, y1}, {x2, y2}] instead of what you have.) Mar 8 '16 at 21:46
• Sorry my English.And thanks four your explaination.
– yode
Mar 8 '16 at 21:48
• Clear["*"]; re = ImplicitRegion[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, y}]; soln = ArgMax[{EuclideanDistance[{x1, y1}, {x2, y2}], {{x1, y1} \[Element] re, {x2, y2} \[Element] re}}, {x1, y1, x2, y2}]; 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[{{soln[[1]], soln[[2]]}, {soln[[3]], soln[[4]]}}]}]. And the ArgMax give a wrong result?
– yode
Mar 8 '16 at 22:00
• What if you used NMaximize[] instead? Mar 8 '16 at 23:07

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}

• Why my same method with you,but give a wrong result?Clear["*"];re=ImplicitRegion[((1.2 x)^2+(1.4 y)^2-1)^3-(1.3 x)^2 y^3==0,{x,y}];soln=ArgMax[{EuclideanDistance[{x1,y1},{x2,y2}],{{x1,y1}[Element]re,{x2,y2}[Element]re}},{x1,y1,x2,y2}]; 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[{{soln[[1]],soln[[2]]},{soln[[3]],soln[[4]]}}]}]
– yode
Mar 29 '16 at 9:11
• @yode I don't know why it fails, maybe a bug? Mar 29 '16 at 9:41
• I think so.Thanks for your confirmation.
– yode
Mar 29 '16 at 9:59