Solve a trig equation system

Question

Background of the problem

In the same plane, P is a fixed point, A,B,C are moving point, PA=a, PB=b, PC=c, find the maximize perimeter of △ABC.

let ∠BPC=A, ∠CPA=B, ∠APB=2*Pi-A-B, then the perimeter of △ABC is Sqrt[b^2+c^2-2 b c Cos[A]]+Sqrt[c^2+a^2-2 c a Cos[B]]+Sqrt[a^2+b^2-2 a b Cos[2Pi-A-B]]

Derivative with respect to A,B we get

$\left\{\frac{b c \sin (A)}{\sqrt{b^2+c^2-2 b c \cos (A)}}=\frac{a c \sin (B)}{\sqrt{a^2+c^2-2 a c \cos (B)}}=\frac{a b \sin (2 \pi-A-B )}{\sqrt{a^2+b^2-2 a b \cos (2 \pi-A-B )}}=k\right\}$

A,B,k are variables, I'm interested in the relations between k and a,b,c. Using Maple I had got this,

$-a^2 b^2 c^2 + (a^2 b^2 + a^2 c^2 + b^2 c^2) k^2 + 2 a b c k^3=0$

but Mathematica seems that solve this difficulty. My code:

eqs={(b c Sin[A])/Sqrt[b^2+c^2-2 b c Cos[A]]==k,
     (a c Sin[B])/Sqrt[a^2+c^2-2 a c Cos[B]]==k,
     (a b Sin[2Pi-A-B])/Sqrt[a^2+b^2-2 a b Cos[2Pi-A-B]]==k};

Solve[eqs, {A,B,k}]

Eliminate[eqs, {A, B}]

Subtract @@@ Map[#^2 &, eqs, {2}] // Together // Numerator
% /. {A -> 2 ArcTan[x], B -> 2 ArcTan[y]} // TrigExpand
Solve[% == 0, {x, y, k}]

Answer 1

I've decided to expand on my comment. Before I delve into the solution, let's all pause for a moment and marvel at the stereographic parametrization of a unit circle:

$$\begin{pmatrix}\frac{1-t^2}{1+t^2}\\\frac{2t}{1+t^2}\end{pmatrix}$$

Sometimes also referred to as the Weierstrass substitution, it has often been used as a tool in the solution of algebraic equations involving circles, or trigonometric functions.

Now, here is something you may not have noticed: though $t$ may take on all possible real values, there is one point on the corresponding unit circle that is inaccessible. In particular, you will never find a value of $t$ corresponding to the point $(-1,0)$.

We now consider OP's problem of finding the triangle of maximal perimeter, given three distances $a,b,c$ from a fixed point. We arbitrarily position this point at $(0,0)$, and then assume $a\leq b\leq c$. We now come to the point where we use the note in the preamble: we can fix one of the corners of the triangle to be at $(-c,0)$. If we do this, we are free to use the Weierstrass substitution on the other two points of the triangle, safe in the knowledge that they will never coincide with the fixed corner.

Let's use OP's example in the comment: $a=3,b=4,c=5$.Here are the required corners:

a = 3; b = 4; c = 5;
corners = {{-c, 0}, b {(1 - u^2)/(1 + u^2), 2 u/(1 + u^2)},
           a {(1 - v^2)/(1 + v^2), 2 v/(1 + v^2)}};

where the two movable points were already put in Weierstrass form. Here is the expression for the perimeter in terms of u and v:

perimeter[u_, v_] = Total[Sqrt[Simplify[#.#]] & /@
                          ListCorrelate[{{-1}, {1}}, corners, 1]]

which yields

Sqrt[(81 + u^2)/(1 + u^2)] + 2 Sqrt[(16 + v^2)/(1 + v^2)] +
Sqrt[(1 - 96 u v + 49 v^2 + u^2 (49 + v^2))/((1 + u^2) (1 + v^2))]

If a numerical solution is all that is wanted, NMaximize[] very quickly find the maximal perimeter:

NMaximize[perimeter[u, v], {u, v}, WorkingPrecision -> 20]
   {20.932330367969337958,
    {u -> -0.47375169871113469216, v -> 0.59656267554477267962}}

If we want exact solutions, we can use Maximize[]. Although the objective function is algebraic, the high algebraic degree will likely mean that the solution will take a long time to find, and that we can likely expect results in terms of Root[]. To help Maximize[] out a bit, we tell it to look for solutions in the right half plane. This corresponds to giving the extra constraints

const = -1 <= u <= 1 && -1 <= v <= 1;

We now do the optimization:

sol = Maximize[{perimeter[u, v], const}, {u, v}] // RootReduce

After a few minutes of hemming and hawing, we now have the exact solution:

{Root[16257024 - 3869200 #1^2 - 1568639 #1^4 + 3600 #1^6 &, 4],
 {u -> Root[729 - 3049 #1^2 - 889 #1^4 + 9 #1^6 &, 3], 
  v -> Root[256 - 721 #1^2 - #1^4 + 16 #1^6 &, 2]}}

It can be verified that the resulting perimeter agrees with the solution returned by NMaximize[], and that the parameter values agree up to a change of sign. To obtain the corresponding points of the triangle, we can do this:

RootReduce[corners /. Last[sol]]
   {{-5, 0}, {Root[-6400 + 769 #1^2 + 90 #1^3 &, 3], 
              Root[1679616 - 2859552 #1^2 + 202561 #1^4 + 8100 #1^6 &, 4]},
    {Root[-2025 + 769 #1^2 + 160 #1^3 &, 3], 
     Root[5308416 - 1309248 #1^2 - 99839 #1^4 + 25600 #1^6 &, 1]}}

and we're done. (Visualizing the resulting triangle is left as an exercise for the interested reader.)

Answer 2

Update

Based on J.M.'s answer, I have improved my ugly code and used his approach. Otherwise the format is as outlined in original answer.

Manipulate[p = {-a, 0}; q = {0, b}; r = {c, 0}; s = mp[a, b, c];
 nfb = RegionNearest[Circle[{0, 0}, b]];
 nfc = RegionNearest[Circle[{0, 0}, c]];
 res = VectorAngle @@@ 
   Partition[Join[{{-a, 0}}, sc[#] & /@ ({u, v} /. s[[2]])], 2, 1, 1];
 Dynamic@Framed[Row[{Column[{{a, b, c}, Column[{p, q, r}],
       Show[
        Graphics[{{Blue, Line[{{0, 0}, #}] & /@ {p, q, r}}, 
          EdgeForm[Black], FaceForm[None], 
          Polygon[{p, q, 
            r}], {Dashed, Red, Circle[{0, 0}, #]} & /@ {a, b, c},
          Locator[Dynamic[q, (q = nfb@#) &]], 
          Locator[Dynamic[r, (r = nfc@#) &]], 
          Text["P", {0, 0}, {0, 1}], Text["B", 1.2 q, {-1, -1}], 
          Text["C", 1.2 r, {1, -1}], Text["A", 1.2 p, {-1, -1}]}], 
        PlotRange -> Table[{-4, 4}, {2}], ImageSize -> 250], 
       Total@(EuclideanDistance @@@ Partition[{p, q, r}, 2, 1, 1]), 
       s[[1]], VectorAngle @@@ Partition[{p, q, r}, 2, 1, 1], res}, 
      Frame -> All],
     Show[mv[a, b, c, res[[1]], res[[2]], Green], 
      mv[a, b, c, VectorAngle[p, q], VectorAngle[q, r], Red], 
      ImageSize -> 300]
     }]], {a, 1, 3}, {{b, 1.5}, 1, 3}, {{c, 2.5}, 1, 3}
 , Initialization :> (sc[u_] := {(1 - u^2)/(1 + u^2), 2 u/(1 + u^2)};
   perimeter[a_, b_, c_, u_, v_] := 
    With[{corners = {{-a, 0}, b sc[u], c sc[v]}},
     Total[
      Sqrt[Simplify[#.#]] & /@ 
       ListCorrelate[{{-1}, {1}}, corners, 1]]];
   mp[a_, b_, c_] := 
    With[{pr = perimeter[a, b, c, u, v]}, 
     NMaximize[{pr, -1 <= u <= 1 && -1 <= v <= 1}, {u, v}]];
   mv[a_, b_, c_, u_, v_, col_] :=
    With[{g = 
       Function[{x, y, l, m, n}, 
        Total@MapThread[
          Sqrt[#1.#1 - 2 (Times @@ #1) Cos[#2]] &, {Partition[{l, m, 
             n}, 2, 1, 1], {x, y, 2 Pi - x - y}}]]},
     Show[
      Plot3D[g[x, y, a, b, c], {x, 0, Pi}, {y, 0, Pi}, 
       Evaluated -> True, Mesh -> False],
      Graphics3D[{col, PointSize[0.02], 
        Point[{u, v, g[u, v, a, b, c]}]}]
      ]];
   )]

Original Answer

This is rather ugly and somewhat inefficient and unstable. However, experts may improve or be motivated to elegant rather than brute force.

per[a_, b_, c_] := With[{p1 = {a, 0}},
   {{#1[[1]], #1[[2]] - #1[[1]], 
       2 Pi - #1[[2]]}, #2} & @@ ({Sort[{t1, t2} /. #2], #1} & @@ 
      Quiet[With[{perim = 
          Total[EuclideanDistance[##] & @@@ 
            Partition[{p1, b {Cos[t1], Sin[t1]}, 
              c {Cos[t2], Sin[t2]}}, 2, 1, 1]]}, 
        NMaximize[perim, {t1, t2}, AccuracyGoal -> 5, 
         PrecisionGoal -> 5]]])];
mv[a_, b_, c_, u_, v_, col_] :=
 With[{g = 
    Function[{x, y, l, m, n}, 
     Total@MapThread[
       Sqrt[#1.#1 - 2 (Times @@ #1) Cos[#2]] &, {Partition[{l, m, n}, 
         2, 1, 1], {x, y, 2 Pi - x - y}}]]},
  Show[Plot3D[g[x, y, a, b, c], {x, 0, Pi}, {y, 0, Pi}, 
    Evaluated -> True, Mesh -> False],
   Graphics3D[{col, PointSize[0.02], Point[{u, v, g[u, v, a, b, c]}]}]
   ]]

DynamicModule[{a, b, c},
 Column[{Grid[{{"a", Slider[Dynamic[a], {1, 3}]},
     {"b", Slider[Dynamic[b], {1, 3}]},
     {"c", Slider[Dynamic[c], {1, 3}]}}],
   Dynamic@
    DynamicModule[{p = {a, 0}, q = {0, b}, r = {-c, 0}, 
      s = per[a, b, c]},
     Dynamic@Framed[Row[{Column[{{a, b, c}, Column[{p, q, r}],

           Show[Graphics[{{Blue, Line[{{0, 0}, #}] & /@ {p, q, r}}, 
              EdgeForm[Black], FaceForm[None], 
              Polygon[{p, q, 
                r}], {Dashed, Red, Circle[{0, 0}, #]} & /@ {a, b, c},

              Locator[
               Dynamic[
                q, (q = RegionNearest[Circle[{0, 0}, b], #]) &]], 
              Locator[
               Dynamic[
                r, (r = RegionNearest[Circle[{0, 0}, c], #]) &]], 
              Text["P", {0, 0}, {0, 1}], Text["B", 1.2 q, {-1, -1}], 
              Text["C", 1.2 r, {1, -1}], Text["A", 1.2 p, {-1, -1}]}],
             PlotRange -> Table[{-4, 4}, {2}], ImageSize -> 250], 
           Total@(EuclideanDistance @@@ 
              Partition[{p, q, r}, 2, 1, 1]), s[[2]], 
           VectorAngle @@@ Partition[{p, q, r}, 2, 1, 1], s[[1]]}, 
          Frame -> All],
         Show[mv[a, b, c, s[[1, 1]], s[[1, 2]], Green], 
          mv[a, b, c, VectorAngle[p, q], VectorAngle[q, r], Red], 
          ImageSize -> 300]
         }]]
     ]}, Frame -> True]]

There are some labeling changes. Here it is assumed $a,b,c$ are given and without loss of generality $P$ is {0,0} and the desired triangle is found by fixing $A$ at {a,0}. The first row is {a,b,c}. The second row are coordinates of A, B, C. The fourth row is measured perimeter for given triangle. The fifth row are the angles between position vectors of triangle and the sixth row is target angles. The graphic on the right is perimeter as function of angles (APB and BPC).

The animated graphic is poor: a combination of code (mainly) and my capture:

This is not ideal and I look forward to better answers.

Answer 3

Since "Visualizing the resulting triangle is left as an exercise for the interested reader" and I am interested here is a visualization of J.M.'s numeric solution.

DynamicModule[{corners, perimeter, sol, u, v, pts},
 Manipulate[
  corners = {{-c, 0}, b {(1 - u^2)/(1 + u^2), 2 u/(1 + u^2)}, 
    a {(1 - v^2)/(1 + v^2), 2 v/(1 + v^2)}};
  perimeter[u_, v_] = 
   Total[Sqrt[Simplify[#.#]] & /@ ListCorrelate[{{-1}, {1}}, corners, 1]];
  sol = NMaximize[perimeter[u, v], {u, v}][[2]];
  pts = corners /. sol;
  Graphics[{
    {Red, PointSize[0.03], Point@pts},
    {Black, Polygon@pts},
    {Hue[0.55], Thick, Line[{{0, 0}, #} & /@ pts]},
    {White, FontSize -> 15, Text["P", {0, 0}, {2, 2}]}
    }],
  {a, 1, 10}, {b, 1, 10}, {c, 1, 10},
  TrackedSymbols :> {a, b, c}
 ]
]