16
$\begingroup$

enter image description here

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}]
$\endgroup$
  • $\begingroup$ …why not Eliminate[(* equations *), {x, y}]? BTW, good on you to use the Weierstrass substitution… $\endgroup$ – J. M. will be back soon Jun 26 '15 at 2:31
  • $\begingroup$ Your optimization problem is unbounded. I can keep dilating the triangle so that the perimeter is always increasing. $\endgroup$ – J. M. will be back soon Jun 27 '15 at 2:39
  • $\begingroup$ @J.M. a,b,c are constant value. For example,when PA=3,PB=4,PC=5, NMaximize[{Sqrt[a^2+b^2-2a b Cos[A+B]]+Sqrt[b^2+c^2-2b c Cos[A]]+Sqrt[c^2+a^2-2c a Cos[B]] /. {a->3,b->4,c->5},0<A<Pi,0<B<Pi},{A,B}] return 20.9323 (Root[16257024-3869200 #1^2-1568639 #1^4+3600 #1^6 &, 4]) $\endgroup$ – mathe Jun 27 '15 at 11:34
  • $\begingroup$ Ah, then I don't think you need to use trigonometric functions. Fix one corner of the triangle, and let the other two move around. $\endgroup$ – J. M. will be back soon Jun 27 '15 at 11:40
23
$\begingroup$

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

$\endgroup$
7
+100
$\begingroup$

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

enter image description here

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:

enter image description here

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

$\endgroup$
5
$\begingroup$

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

enter image description here

$\endgroup$
  • $\begingroup$ simplicity and visually clear +1,,,I update my answer with J.M.'s insight and function (with attribution) and in process learned a lot about how to constrain locators and challenges of Dynamic,,,yet to really understand. :) $\endgroup$ – ubpdqn Jun 29 '15 at 11:38

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.