# Inscribed square problem

There is a well-known unsolved problem in geometry:

$\textbf{Toeplitz' conjecture}:$ Every continuous simple closed curve in the plane contains four points that are the vertices of a square.

How to check this conjecture for the "heart curve" by using Mathematica?

 PolarPlot[
2 - 2 Sin[t] + Sin[t] Sqrt[Abs[Cos[t]]]/(Sin[t] + 1.4),
{t, 0,2 Pi}, PlotStyle -> Red, Ticks -> None]


$$r(t )=\frac{\sin (t) \sqrt{\left| \cos (t)\right| }}{\sin (t)+1.4}-2 \sin (t)+2$$

How to find (and plot) four points on the "heart curve" that are the vertices of a square?

We can use symmetry and find such points that have the same $x$ coordinate and difference of their $y$ coordinates is twice the $x$ coordinate. We use FindRoot and help it with initial point which we choose as the maximum $x$ coordinate - maxXt. Then we need to mirror two points and draw lines between.

r[t_] := 2 - 2 Sin[t] + Sin[t] Sqrt[Abs[Cos[t]]]/(Sin[t] + 1.4)

maxXt = t /. Last@Maximize[r[t] Cos[t], {t}];

sol = FindRoot[{r[t1] Cos[t1] == r[t2] Cos[t2],
r[t1] Sin[t1] - r[t2] Sin[t2] == 2 r[t1] Cos[t1]}, {{t1,
maxXt}, {t2, maxXt}}];
p[t_] := {r[t] Cos[t], r[t] Sin[t]};
vert = p /@ {t1, t2} /. sol; (* two right points *)
vertMir = RotateLeft[{-1, 1} # & /@ vert]; (* two left points in right order for ListPlot*)

Show[PolarPlot[r[t], {t, 0, 2 Pi}, PlotStyle -> Red, Ticks -> None],
ListPlot[vert~Join~vertMir~Join~vert[[1 ;; 1]], Joined -> True, PlotMarkers -> Automatic]]


Update: Finding a similar heart that has $45^o$ tilted square inscribed too.

At $t=\pi/2$ and $t=-\pi/2$ we have points with singularity. Let's see if we can deform the heart so our inscribed square will have its diagonal between those points.

r[t_, b_] := 2 - 2 Sin[t] + b Sin[t] Sqrt[Abs[Cos[t]]]/(Sin[t] + 1.4);
Manipulate[
Show[#, Frame -> True] &@
PolarPlot[r[t, b], {t, 0, 2 Pi}, PlotStyle -> Red, Ticks -> None,
Axes -> None, PlotRange -> {{-2.5, 2.5}, {-4, 1}}], {b, 0, 2,
0.05}]


We need to find parameter b such that at $t =${Pi/2, 5 Pi/4, 3 Pi/2, 7 Pi/4} we are getting a square. It's easy we just have to state that

$r(5\pi/4,b)\sqrt 2 = r(3\pi/2,b)$

The other not tilted square is still there so we can find it the same way as earlier.

bDiag = b /.
FindRoot[r[5 Pi/4, b] Sqrt[2] == r[3 Pi/2, b], {b, 0.8}]; (* b=0.682619 *)
diag = r[#, bDiag] {Cos[#], Sin[#]} & /@ {Pi/2, 5 Pi/4, 3 Pi/2,7 Pi/4, Pi/2};

sol = FindRoot[{r[t1, bDiag] Cos[t1] == r[t2, bDiag] Cos[t2],
r[t1, bDiag] Sin[t1] - r[t2, bDiag] Sin[t2] ==
2 r[t1, bDiag] Cos[t1]}, {{t1, Pi/8, 0, Pi/4}, {t2, -Pi/4, -Pi/2,
0}}];
p[t_] := {r[t, bDiag] Cos[t], r[t, bDiag] Sin[t]};
vert = p /@ {t1, t2} /. sol;
vertMir = RotateLeft[{-1, 1} # & /@ vert];
str = vert~Join~vertMir~Join~vert[[1 ;; 1]];

Show[PolarPlot[r[t, bDiag], {t, 0, 2 Pi}, PlotStyle -> Red, Axes -> None],
ListPlot[{str, diag}, Joined -> True, PlotMarkers -> Automatic],Frame ->True]


• You can do maxXt = ArgMax[r[t] Cos[t], t] instead. Jun 1 '16 at 17:05
• @J.M. Thanks! Never knew it exists... Jun 1 '16 at 17:08
• On another note: this finds only one square. I wonder how difficult it would be to prove or disprove that it is the only such square for this curve? Jun 1 '16 at 17:12
• It's obvious that it's the only one that has the same symmetry as the curve itself... Not sure how to try to find an arbitrary tilted one. The brute force of finding four $t$ in FindRoot wouldn't work probably. Jun 1 '16 at 17:15
• Yes, the part after your "not sure" was what I was thinking about; I can see how difficult it might be to do. Jun 1 '16 at 17:23

This is just for fun. The square is found by finding the difference in lengths of adjacent sides of rectangle is zero. This exploits the symmetry in the y axis to find the square and does not address whether this is the only square set of points (i.e 'tilted' as referred to in comments). It is not particularly efficient.

r[t_] := 2 - 2 Sin[t] + Sin[t] Sqrt[Abs[Cos[t]]]/(Sin[t] + 1.4);
p[t_] := r[t] {Cos[t], Sin[t]};
rec[t_] := Module[{v1 = p[t], v2, n, v3, v4},
v2 = {-1, 1} v1;
n = {0, 1};
{v3, v4} = {p[s], {-1, 1} p[s]} /.
First@NSolve[v1 + k n == p[s] && 0 <= s <= 2 Pi && s != t, {k, s},
Reals];
{v1, v3, v4, v2}]
df[t_] := With[{res = Quiet@rec[t]},
#1^2 - #2^2 & @@ ({#2[[2]] - #1[[2]], #3[[1]] - #2[[1]]} & @@ res)]
tab = Table[{j, df[j]}, {j, 0, Pi/2, 0.01}];
ip = Interpolation[tab];
root = u /. FindRoot[ip[u], {u, 0.3}];


Visualizing:

fun[t_] := Module[{pts = Quiet@rec[t], sq = Quiet@rec[root], circ},
circ = 1/2 (sq[[1]] + sq[[3]]);
PolarPlot[r[u], {u, 0, 2 Pi},
Epilog -> {PointSize[0.02], Point[pts], EdgeForm[Red],
FaceForm[None], Polygon[pts], Red, Point[sq],
EdgeForm[{Purple, Thick}], Polygon[sq], Orange, Thickness[0.01],
Circle[circ, EuclideanDistance[circ, sq[[1]]]], Point[circ]},
ImageSize -> 300, PlotRange -> {-4, 1}]
]
anim = Table[
Row[{fun[par],
Plot[Quiet@ip[w], {w, 0, Pi/2},
Epilog -> {PointSize[0.02], Point[{par, ip[par]}]},
Frame -> True, ImageSize -> 300]}], {par, 0.0, 1.5, 0.01}];


anim was exported as gif.

• @vito thank you for kindly accepting my answer. I think BlacKow is a better answer and I have not addressed whether there are other squares (though I suspect it unlikely). I only answered find a square in this closed figure. Suspicion is not proof. :) Jun 3 '16 at 10:33
• neat animation always wins! Jun 3 '16 at 16:35
• @ubpdqn ok :) I go back on my decision ;)
– vito
Jun 6 '16 at 9:41