Inscribed square problem

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]]

enter image description here

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}] 

enter image description here

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]

enter image description here


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.

enter image description here