9
$\begingroup$

Suppose you have an equation with various roots as in $\sqrt a + \sqrt b = \sqrt c$.

Sqrt[a] + Sqrt[b] == Sqrt[c]

Is there a Mathematica command or program that will create an equation free of roots so that, aside from possible extraneous solutions, it is equivalent to the original equation, in this case $a^2+b^2+c^2-2ab-2bc-2ca=0$.

a^2+b^2+c^2-2*a*b-2*b*c-2*c*a==0

A test of the algorithm can be the case of generalized ellipse/oval $\sum_{i=1}^n r_i \sqrt{(x-a_i)^2+(y-b_i)^2} =T$ with $n \ge 2$.

$\endgroup$
  • 4
    $\begingroup$ At least for this case: GroebnerBasis[{Sqrt[a] + Sqrt[b] == Sqrt[c]}, {a, b, c}, MonomialOrder -> EliminationOrder] // Last $\endgroup$ – J. M. will be back soon May 18 '17 at 20:48
  • $\begingroup$ @J.M. the code works for the given example but does not seem to work for a case with more variable, eg, GroebnerBasis[{n1*Sqrt[(x - a1)^2 + y^2] + n2*Sqrt[(x - a2)^2 + y^2] == T}, {n1, n2, a1, a2, T, x, y}, MonomialOrder -> EliminationOrder] // Last $\endgroup$ – Maesumi May 19 '17 at 0:32
  • 3
    $\begingroup$ Well... GroebnerBasis[{n1*Sqrt[(x - a1)^2 + y^2] + n2*Sqrt[(x - a2)^2 + y^2] == T}, {x, y, T, n1, n2, a1, a2}][[1]] (That's why I didn't post a solution yet; I have nothing automatable.) $\endgroup$ – J. M. will be back soon May 19 '17 at 2:53
3
$\begingroup$

I've done this before by replacing fractional powers by a variable and introducing appropriate relations (such as under "Set-up" here). Then you eliminate the new variables.

rat[eq_] := Module[{eqn, rads, reps, i, u},
  eqn = eq /. Equal -> Subtract;
  rads = DeleteDuplicates@Cases[eqn, Sqrt[_], Infinity];
  reps = (i = 0; # -> u[++i] & /@ rads);
  Eliminate[
   Append[(i = 0; First[#] == u[++i]^2 & /@ rads), eqn == 0 /. reps],
   Array[u, Length@rads]
   ]
  ]

rat[Sqrt[a] + Sqrt[b] == Sqrt[c]]
(*  -b^2 + 2 b c - c^2 == a^2 + a (-2 b - 2 c)  *)

eee[n_] := Sum[r[i] Sqrt[(x[i] - a[i])^2 + (y[i] - b[i])^2], {i, n}] == T;

rat[eee[2]]
(*  T^4 + T^2 (-2 a[1]^2 r[1]^2 - ...) == -a[1]^4 r[1]^4 - ... - r[2]^4 y[2]^4  *)

rat[eee[3]]
(* takes a bit longer than lunch :)
  T^8 + T^6 (...) + ... == ...
*)

Each square root doubles the degree. The combinatorial explosion possible can be seen by adding just a linear term to the first example:

rat[Sqrt[a] + Sqrt[b] == Sqrt[c] + x]
(*
  a^4 + a^3 (-4 b - 4 c - 4 x^2) + 
    a^2 (6 b^2 + 4 b c + 6 c^2 + 4 b x^2 + 4 c x^2 + 6 x^4) + 
    a (-4 b^3 + 4 b^2 c + 4 b c^2 - 4 c^3 + 4 b^2 x^2 - 40 b c x^2 + 
       4 c^2 x^2 + 4 b x^4 + 4 c x^4 - 4 x^6) == -b^4 + 4 b^3 c - 
    6 b^2 c^2 + 4 b c^3 - c^4 + 4 b^3 x^2 - 4 b^2 c x^2 - 4 b c^2 x^2 + 
    4 c^3 x^2 - 6 b^2 x^4 - 4 b c x^4 - 6 c^2 x^4 + 4 b x^6 + 4 c x^6 - x^8
*)
$\endgroup$
3
$\begingroup$

Here a simple and very fast procedure to eliminate the square roots.

First bring all summands of the equation on one side and make a list.

list = List @@ (Sqrt[a] + Sqrt[b] - Sqrt[c] - x);

Then define Tuples and delete the ones that differ only by factor -1.

tup[n_ ] := Tuples[{-1, 1}, n];

uni = Union[tup[4], SameTest -> (#1 == -#2 &)]

(* {{-1, -1, -1, -1}, {-1, -1, -1, 1}, {-1, -1, 1, -1}, {-1, -1, 1, 
     1}, {-1, 1, -1, -1}, {-1, 1, -1, 1}, {-1, 1, 1, -1}, {-1, 1, 1, 1}} *)

Now multipliy the equation with all these selected tuples.

Times @@ (Plus @@ # & /@ (list*# & /@ uni)) // Expand

(*    a^4 - 4 a^3 b + 6 a^2 b^2 - 4 a b^3 + b^4 - 4 a^3 c + 4 a^2 b c + 
   4 a b^2 c - 4 b^3 c + 6 a^2 c^2 + 4 a b c^2 + 6 b^2 c^2 - 4 a c^3 - 
   4 b c^3 + c^4 - 4 a^3 x^2 + 4 a^2 b x^2 + 4 a b^2 x^2 - 4 b^3 x^2 + 
   4 a^2 c x^2 - 40 a b c x^2 + 4 b^2 c x^2 + 4 a c^2 x^2 + 
   4 b c^2 x^2 - 4 c^3 x^2 + 6 a^2 x^4 + 4 a b x^4 + 6 b^2 x^4 + 
   4 a c x^4 + 4 b c x^4 + 6 c^2 x^4 - 4 a x^6 - 4 b x^6 - 4 c x^6 + x^8    *)

This works for all dinensions and for your general example.

su = Sum[r[i] Sqrt[(x[i] - a[i])^2 + (y[i] - b[i])^2], {i, 3}] - T;

list = List @@ su

uni = Union[tup[4], SameTest -> (#1 == -#2 &)]

Times @@ (Plus @@ # & /@ (list*# & /@ uni)) // Expand

(*    A very large output was generated
    T^8-4 T^6 a[1]^2 r[1]^2-....    *)

Appendix

In general you have to multiply with Length[onesided equation] tuples

(( Sqrt[a] + Sqrt[b] - Sqrt[c]) (- Sqrt[a] + Sqrt[b] - Sqrt[
  c]) (- Sqrt[a] - Sqrt[b] - Sqrt[c]) ( 
 Sqrt[a] - Sqrt[b] - Sqrt[c]) // Expand) == 0

(*  a^2 - 2 a b + b^2 - 2 a c - 2 b c + c^2 == 0   *)

But if you have less than Length[...]-1 square roots, you only have to permutate sign of the square root summands to get the minimal form

(( Sqrt[a] + b - c) (- Sqrt[a] + b - c) // Expand) == 0

(*    -a + b^2 - 2 b c + c^2 == 0    *)

(( Sqrt[a] + Sqrt[b] - c + d) (- Sqrt[a] + Sqrt[b] - c + 
  d) (- Sqrt[a] - Sqrt[b] - c + d) ( Sqrt[a] - Sqrt[b] - c + d) //
Expand) == 0

(*  a^2 - 2 a b + b^2 - 2 a c^2 - 2 b c^2 + c^4 + 4 a c d + 4 b c d - 
    4 c^3 d - 2 a d^2 - 2 b d^2 + 6 c^2 d^2 - 4 c d^3 + d^4 == 0    *)
$\endgroup$
3
$\begingroup$

This is not so different from the response by @MichaelE2, but probably faster on larger problems (don't expect miracles though). It has the weakness of requiring that radicals be algebraically independent. That could be removed but it would take some work.

I'll work with expressions rather than equations so that Variables and the like behave.

The example:

expr = n1*Sqrt[(x - a1)^2 + y^2] + n2*Sqrt[(x - a2)^2 + y^2] - T;

Get the variables and the radicals, the latter in the convenient form of {radicand,power}.

vars = Variables[expr]
rads = Union[Cases[expr, Power[a_, b_Rational] :> {a, b}, Infinity]]

(* Out[296]= {a1, a2, n1, n2, T, x, y}

Out[297]= {{(-a1 + x)^2 + y^2, 1/2}, {(-a2 + x)^2 + y^2, 1/2}} *)

Create a new variable and defining relation for each, and then substitue the new variables for the radicals in the original expression.

newvars = Array[rad, Length[rads]];
replacement = Thread[rads[[All, 1]]^rads[[All, 2]] -> newvars];
newexprs = 
  Thread[newvars^Denominator[rads[[All, 2]]] - 
    rads[[All, 1]]^Numerator[rads[[All, 2]]]];
newexpr = expr /. replacement;

Now eliminate the new variables.

AbsoluteTiming[
 First[GroebnerBasis[Flatten[{newexprs, newexpr}], vars, newvars, 
   MonomialOrder -> EliminationOrder]]]

(* Out[303]= {0.002461, 
 a1^4 n1^4 - 2 a1^2 a2^2 n1^2 n2^2 + a2^4 n2^4 - 2 a1^2 n1^2 T^2 - 
  2 a2^2 n2^2 T^2 + T^4 - 4 a1^3 n1^4 x + 4 a1^2 a2 n1^2 n2^2 x + 
  4 a1 a2^2 n1^2 n2^2 x - 4 a2^3 n2^4 x + 4 a1 n1^2 T^2 x + 
  4 a2 n2^2 T^2 x + 6 a1^2 n1^4 x^2 - 2 a1^2 n1^2 n2^2 x^2 - 
  8 a1 a2 n1^2 n2^2 x^2 - 2 a2^2 n1^2 n2^2 x^2 + 6 a2^2 n2^4 x^2 - 
  2 n1^2 T^2 x^2 - 2 n2^2 T^2 x^2 - 4 a1 n1^4 x^3 + 
  4 a1 n1^2 n2^2 x^3 + 4 a2 n1^2 n2^2 x^3 - 4 a2 n2^4 x^3 + 
  n1^4 x^4 - 2 n1^2 n2^2 x^4 + n2^4 x^4 + 2 a1^2 n1^4 y^2 - 
  2 a1^2 n1^2 n2^2 y^2 - 2 a2^2 n1^2 n2^2 y^2 + 2 a2^2 n2^4 y^2 - 
  2 n1^2 T^2 y^2 - 2 n2^2 T^2 y^2 - 4 a1 n1^4 x y^2 + 
  4 a1 n1^2 n2^2 x y^2 + 4 a2 n1^2 n2^2 x y^2 - 4 a2 n2^4 x y^2 + 
  2 n1^4 x^2 y^2 - 4 n1^2 n2^2 x^2 y^2 + 2 n2^4 x^2 y^2 + n1^4 y^4 - 
  2 n1^2 n2^2 y^4 + n2^4 y^4} *)

For eee[3] in the prior response it produces a result of leaf count around 150K in somewhat under a second. Given eee[4] it ran out of memory on my low-RAM desk top after 3-4 minutes (kernel crash). Might or might not fare better on a bigger machine.

Update: eee[4] ran to completion on a machine with more memory. It took approximately a day. It's larger than the print code cares to consider.

$\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.