Inscribed square problem

Question

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?

Answer 1

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]

Answer 2

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.