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