7
$\begingroup$

There is my earlier question about Inscribed square problem

Now I tried to find the general solution for any curve $f(x,y)=0$.

For instance :

$\qquad \left(x^2+y^2-1\right)^3-x^2 y^3=0$

ContourPlot[(-1 + x^2 + y^2)^3 == x^2*y^3, {x, -1.4, 1.4}, {y, -1.3, 1.5},
Frame -> False, PlotPoints -> 200]

enter image description here

There are three general conditions to find vertices of a square:

Coordinates of vertices are $(p1,k1),(p2,k2),(p3,k3),(p4,k4)$

Let

g[x_, y_] := (x^2 + y^2 - 1)^3 - x^2 y^3

$1.$ Vertex coordinates satisfy heart equation $g(x,y)=0$

eq1 = g[p1, k1] == 0;
eq2 = g[p2, k2] == 0;
eq3 = g[p3, k3] == 0;
eq4 = g[p4, k4] == 0;

$2.$ All sides have equal length.

eq5 = 
  EuclideanDistance[{p1, k1}, {p2, k2}] == 
  EuclideanDistance[{p2, k2}, {p3, k3}] == 
  EuclideanDistance[{p3, k3}, {p4, k4}] == 
  EuclideanDistance[{p1, k1}, {p4, k4}];

$3.$ Every interior angle is a right angle

angle1 = VectorAngle[{p4 - p1, k4 - k1}, {p2 - p1, k2 - k1}] == Pi/2;
angle2 = VectorAngle[{p1 - p2, k1 - k2}, {p3 - p2, k3 - k2}] == Pi/2;
angle3 = VectorAngle[{p4 - p3, k4 - k3}, {p2 - p3, k2 - k3}] == Pi/2;


NSolve[eq1 && eq2 && eq3 && eq4 && eq5 && angle1 && angle2 && 
angle3, {p1, p2, p3, p4, k1, k2, k3, k4}]

But there is no answer.

How can I solve the following system of equation by using Mathematica?

g[x_, y_] := (x^2 + y^2 - 1)^3 - x^2 y^3

eq1 = g[p1, k1] == 0;
eq2 = g[p2, k2] == 0;
eq3 = g[p3, k3] == 0;
eq4 = g[p4, k4] == 0;

eq5 = 
  EuclideanDistance[{p1, k1}, {p2, k2}] == 
  EuclideanDistance[{p2, k2}, {p3, k3}] == 
  EuclideanDistance[{p3, k3}, {p4, k4}] == 
  EuclideanDistance[{p1, k1}, {p4, k4}];

angle1 = VectorAngle[{p4 - p1, k4 - k1}, {p2 - p1, k2 - k1}] == Pi/2;
angle2 = VectorAngle[{p1 - p2, k1 - k2}, {p3 - p2, k3 - k2}] == Pi/2;
angle3 = VectorAngle[{p4 - p3, k4 - k3}, {p2 - p3, k2 - k3}] == Pi/2;
$\endgroup$
  • 2
    $\begingroup$ You have 9 equations, and 8 variables. $\endgroup$ – Feyre Dec 25 '16 at 14:07
  • 3
    $\begingroup$ You only need three equations concerning the vertex angles. If three of them are right angles, the fourth must be a right angle. $\endgroup$ – m_goldberg Dec 25 '16 at 15:20
  • $\begingroup$ @m_goldberg ok, I tried 8 equation, (three equations concerning the vertex angles) but there is no answer.. $\endgroup$ – vito Jan 24 '17 at 17:09
  • $\begingroup$ These problems and solutions are highly constrained. The conjecture holds for an arbitrary closed non-self-intersecting curve. How would you find the point here? PolarPlot[Cos[t] + .3 Sin[3 t] + .1 Cos[7 t - .4] + .3 Cos[9 t], {t, 0, 2 \[Pi]}] And how would one find all the inscribed squares? $\endgroup$ – David G. Stork Jul 2 '17 at 2:06
3
$\begingroup$

For square ABCD, given $A(x_1, y_1)$, $B(x_2, y_2)$, $C$ and $D$ are easy to get, so we can reduce the number of unknowns to 4
enter image description here

Clear["`*"];
f[x_, y_] := (x^2 + y^2 - 1)^3 - x^2 y^3;
pts = NestList[RotationMatrix[π/2].(# - {x1, y1}) + {x2, y2} &, {x1, y1}, 3]
eqn = f @@@ pts
sol = FindRoot[eqn, Transpose[{{x1, y1, x2, y2}, {0, 1, -1, 0}}]]
ContourPlot[f[x, y] == 0, {x, -1.4, 1.4}, {y, -1.3, 1.5},
 Epilog -> ({PointSize[Large], Point[pts], Line[pts[[{1, 2, 3, 4, 1}]]]} /. sol)]

enter image description here
You can also use NMinimize to solve the equation, no initial value is required

nm=NMinimize[Join[{Total[eqn^2],1/2<x1-x2<2},Thread[eqn==0]],{x1,y1,x2,y2},WorkingPrecision->50]/.x_Real:>Round[x,10^-15.]

{0., {x1 -> 1., y1 -> 0., x2 -> 0., y2 -> 1.}}

| improve this answer | |
$\endgroup$
2
$\begingroup$

Well done @yarchik.

But Solve can show the solution in Reals with an extra option:

Solve[(r^2 - 1)^3 == r^5 Cos[ϕ]^2 Sin[ϕ]^3, r, Reals]

({ {r -> Root[-1 + 3 #1^2 - 3 #1^4 - Cos[[Phi]]^2 Sin[[Phi]]^3 #1^5 + #1^6 &, 1]}, {r -> Root[-1 + 3 #1^2 - 3 #1^4 - Cos[ϕ]^2 Sin[ϕ]^3 #1^5 + #1^6 &, 2]}})

and even further

Solve[(r^2 - 1)^3 == r^5 Cos[ϕ]^2 Sin[ϕ]^3 && 
  0 < ϕ < 2 π, r, Reals]

{{r -> ConditionalExpression[
    Root[-1 + 3 #1^2 - 3 #1^4 - 
       Cos[ϕ]^2 Sin[ϕ]^3 #1^5 + #1^6 &, 1], 
    0 < ϕ < π/2 || π/
      2 < ϕ < π || π < ϕ < (3 \[Pi])/2 || (3 π)/
      2 < ϕ < 2 π]}, 

{r -> 
       ConditionalExpression[
        Root[-1 + 3 #1^2 - 3 #1^4 - 
           Cos[ϕ]^2 Sin[ϕ]^3 #1^5 + #1^6 &, 2], 
        0 < ϕ < π/2 || π/
          2 < ϕ < π || π < ϕ < (3 π)/2 || (3 π)/
          2 < ϕ < 2 π]}}

Powerful Solve is not it.

Compared to the solution already given this is just a formal step ahead. But both real solutions to Solve form the heart curve in polar coordinates lead to the same inscribed square.

| improve this answer | |
$\endgroup$
1
$\begingroup$

The problem is difficult to solve in Cartesian coordinates. But it simplifies a lot in polar coordinates. Let us first convert the given implicit equation into this form. We substitute $x=r\cos\phi$, $y=r\sin\phi$ and obtain

$$(r^2-1)^3=r^5 \cos^2\phi \sin^3\phi.$$

This is an algebraic equation for $r$.

Solve[(r^2-1)^3==r^5 Cos[ϕ]^2 Sin[ϕ]^3,r]

Upon inspection we find the positive real root is number 2. Now define the function in polar coordinates:

rH[ϕ_]:=Abs[Root[-1+3#1^2-3  #1^4-Cos[ϕ]^2 Sin[ϕ]^3 #1^5+#1^6&,2]]
xy[ϕ_]:=rH[ϕ]{Cos[ϕ],Sin[ϕ]}

Only 4 equations need to be solved:

eq1=EuclideanDistance[xy[t1],xy[t2]]==EuclideanDistance[xy[t2],xy[t3]]==EuclideanDistance[xy[t4],xy[t1]];
eq2=VectorAngle[xy[t1]-xy[t2],xy[t2]-xy[t3]]==Pi/2;
eq3=VectorAngle[xy[t4]-xy[t1],xy[t1]-xy[t2]]==Pi/2;

Let us invent some initial guess for FindRoot

δ=0.2;

and do the calculations

res=FindRoot[{eq1,eq2,eq3},{{t1,0+δ},{t2,π/2+δ},{t3,π+δ},{t4,3π/2+δ}},AccuracyGoal->5];

pts=xy[N[#]]&/@({t1,t2,t3,t4,t1}/.res);

PolarPlot[rH[ϕ],{ϕ,0,2π},PlotRange->All,Axes->False,Epilog->{PointSize->Large,Point[#]&/@pts,Line[pts]}]

enter image description here

It is easy to verify that $\phi_i=\pi/2(i-1)$ is an exact solution.

| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.