6
$\begingroup$

I'm working on a geometry problem and would like to create a function to create a triangle based on the logical constructs output by Reduce but cannot obtain all the constructs. Here's the problem:

Given the vertices of a triangle $A=(p,q), B=(r,s), C=(u,v)$ obeying the constraints $2p+3r+4u=0$, $2q+3s+4v=0$ with the origin $O$ lying interior to the triangle, find $r$ such that $[OBC]=r[ABC]$. So using the Shoe-String Theorem, I set up expressions:

(u s - r v) == -r (p s + r v + u q - p v - u s - r q) && 2 p + 3 r + 4 u == 0 && 2 q + 3 s + 4 v == 0 && u < 0 && 0 < r < 1 && p > 0 && s < 0 && q > 0

and solve for $r$ using Reduce:

Clear[p, q, r, s, u, v]
mysol = Reduce[(u s - 
      r v) == -r (p  s + r  v + u q - p  v - u  s - r  q) && 
   2 p + 3 r + 4 u == 0 && 2 q + 3 s + 4 v == 0 && u < 0  && 
   0 < r < 1 && p > 0 && s < 0  && q > 0 , r, Reals]

This returns

((v <= 0 && s < 0 && u < -(1/6) && p == 1/3 (-1 - 6 u)) || (v > 0 && 
     s < -((4 v)/3) && u < -(1/6) && p == 1/3 (-1 - 6 u))) && 
 q == (-(1/3) p s (-2 p - 4 u) - s u + 1/3 s (-2 p - 4 u) u + 
   1/3 (-2 p - 4 u) v + 1/3 p (-2 p - 4 u) v - 
   1/9 (-2 p - 4 u)^2 v)/(-(1/9) (-2 p - 4 u)^2 + 
   1/3 (-2 p - 4 u) u) && r == 1/3 (-2 p - 4 u)

From this expression, I would like to create a function:

getTriangle[v_,s_,u_]

which first checks that v,s,u meet the constraints of Reduce, then proceeds to compute p,q,and r.

I can extract the expressions for $q$ and $r$ with the following code:

myq = q /. ToRules @@ Cases[mysol, q == qval__];
myr = r /. ToRules @@ Cases[mysol, r == rval__];

but I'm unable to obtain the expression for p using a similar construct as well as the constraints for v,s,u and was wondering if someone could help me with this? As I would want to change the constraints, would like to programatically create the function rather than just manually extract the expressions by hand.

$\endgroup$
4
$\begingroup$

Perhaps the following. It has the traditional output of Solve when no solution exists.

ClearAll[getTriangle];
Apply[SetDelayed,
 Hold[getTriangle[v_, s_, u_], Solve["eq", {p, q, r}]] /. "eq" -> mysol
 ]

Triangle exists:

getTriangle[-1, -2, -1]
(*  {{p -> 5/3, q -> 5, r -> 2/9}}  *)

Triangle does not exist:

getTriangle[-1, -2, 1]
(*  {}  *)

Alternative definition:

Unevaluated[getTriangle[v_, s_, u_] := Solve[mysol, {p, q, r}]] /. 
 HoldPattern[mysol] -> mysol
| improve this answer | |
$\endgroup$
  • $\begingroup$ . . .wow! Always a pleasure working with you guys. Thanks Michael. $\endgroup$ – Dominic Dec 19 '19 at 14:13
  • $\begingroup$ Pardon me Michael, but I removed my vote for this because I think there is a better way, unless you can show me that my approach fails. $\endgroup$ – Mr.Wizard Dec 19 '19 at 14:38
  • 1
    $\begingroup$ @Mr.Wizard Already upvoted yours. :) I can't believe I forgot about BackSubsitution. I seem to recall that it may have been what I needed a year ago or so, but I'll never remember for what. Hopefully Dominic will see your solution. Solving once is certainly more efficient than solving each time. $\endgroup$ – Michael E2 Dec 19 '19 at 14:39
  • $\begingroup$ Thanks guys. Will try them out once I iron out a bug with my Mainpulate. I'll create a different thread since it's independent of this one. $\endgroup$ – Dominic Dec 19 '19 at 16:14
4
$\begingroup$

If we change the parameters of Reduce we can get this:

Reduce[(u s - r v) == -r (p s + r v + u q - p v - u s - r q) && 
  2 p + 3 r + 4 u == 0 && 2 q + 3 s + 4 v == 0 && u < 0 && 0 < r < 1 && p > 0 && 
  s < 0 && q > 0, {r, p, q}, Reals, Backsubstitution -> True]
(v <= 0 && s < 0 && u < -(1/6) && r == 2/9 && p == 1/3 (-1 - 6 u) && 
   q == 1/2 (-3 s - 4 v)) || (v > 0 && s < -((4 v)/3) && u < -(1/6) && r == 2/9 && 
   p == 1/3 (-1 - 6 u) && q == 1/2 (-3 s - 4 v))

From which we can make a direct definition, eliminating Solve and producing solutions some two orders of magnitude faster than Michael's solution.

tri[v_, s_, u_ /; u < -1/6] :=
  {{p -> 1/3 (-1 - 6 u), q -> 1/2 (-3 s - 4 v), r -> 2/9}} /;
     (v <= 0 && s < 0) || (v > 0 && s < -((4 v)/3))

tri[_, _, _] = {};

Test:

res1 = Array[getTriangle, {11, 11, 11}, -5]; // RepeatedTiming
res2 = Array[tri, {11, 11, 11}, -5];         // RepeatedTiming
res1 === res2
{0.74, Null}

{0.00482, Null}

True

Inspired by Michael's comment regarding Solve, here is another approach:

sol = Solve[(u s - r v) == -r (p s + r v + u q - p v - u s - r q) && 
     2 p + 3 r + 4 u == 0 && 2 q + 3 s + 4 v == 0 && u < 0 && 0 < r < 1 && p > 0 && 
     s < 0 && q > 0, {p, q, r}, Reals] // FullSimplify;

{p, q, r} /. sol[[1]];
Thread[%, ConditionalExpression];
MapAt[Apply[And], %, 2]
ConditionalExpression[{-(1/3) - 2 u, -((3 s)/2) - 2 v, 2/9},
  (s < 0 && u < -(1/6) && v < 0) || (u < -(1/6) && v > 0 && 3 s + 4 v < 0)]
| improve this answer | |
$\endgroup$
  • 1
    $\begingroup$ One could use Solve instead of Reduce, too. You get a solution in terms of ConditionalExpression/Undefined. Solve is probably the first thing that should have been tried in the first place, since obtaining a solution is the goal. $\endgroup$ – Michael E2 Dec 19 '19 at 14:45
  • $\begingroup$ @MichaelE2 Great point! $\endgroup$ – Mr.Wizard Dec 19 '19 at 14:48
0
$\begingroup$

Ok, here's the complete Manipulate code (without the most recent suggestion yet and the custom label code for the points removed too). I couldn't use the built-in TriangleMeasurement function as it seems to have a bug: Stack link to description of problem

Note the values $[OCB]$ and $r[ABC]$ are always equal for the range I'm plotting. Pretty nice I think! Thanks for helping me guys.
enter image description here

tArea[a_, b_, c_] := Module[{semi, ab, ac, bc},
   ab = EuclideanDistance[a, b];
   ac = EuclideanDistance[a, c];
   bc = EuclideanDistance[b, c];
   semi = (ab + ac + bc)/2;
   Sqrt[semi (semi - ab) (semi - ac) (semi - bc)]
   ];

uft = 0.3;
Clear[p, q, r, s, u, v];
ClearAll[getTriangle];
mysol = Reduce[(u s - 
       r v) == -r (p  s + r  v + u q - p  v - u  s - r  q) && 
    2 p + 3 r + 4 u == 0 && 2 q + 3 s + 4 v == 0 && u < 0  && 
    0 < r < 1 && p > 0 && s < 0  && q > 0 , r, Reals];
Apply[SetDelayed, 
  Hold[getTriangle[v_, s_, u_], NSolve["eq", {p, q, r}]] /. 
   "eq" -> mysol];

Manipulate[
 {p2, q2, r2} = {p, q, r} /. getTriangle[v2, s2, u2] // First;
 a = {p2, q2};
 b = {r2, s2};
 c = {u2, v2};
 o = {0, 0};
 myTriangle = {EdgeForm[Black], FaceForm[], Triangle@{a, b, c}};
 ocbArea = tArea[o, b, c];
 abcArea = tArea[a, b, c];
 text1 = Text[Style["[OCB]= " <> ToString@ocbArea, 16], {-3, 4}];
 text2 = Text[Style["r[ABC]= " <> ToString@(r2 abcArea), 16], {-3, 3}];
 Show[Graphics@{myTriangle, text1, text2, Line@{o, c}, Line@{o, b}, 
    Line@{o, a}}, Axes -> True, 
  PlotRange -> 
   5], {{v2, -1}, -0.1, -5}, {{s2, -1}, -0.1, -5}, {{u2, -1}, -0.3, \
-5}, TrackedSymbols :> True]
| 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.