8
$\begingroup$

When I solve the aforementioned equation for $W$ or $A$ on Mathematica I get a long and ugly equation in return, namely one of the solutions for $W$ is: (attempt to read at your own health)

Solve[L == (3 W)/2 + (3 Sqrt[4 A^2 Pi^2 + W^2])/2 - Sqrt[6 A^2 Pi^2 + 3 W^2 +
  5 W Sqrt[4 A^2 Pi^2 + W^2]]/Sqrt[2], W]

$W=\frac{3 L}{10}-\frac{1}{2} \sqrt{\frac{\sqrt[3]{-243200 \pi ^6 A^6+176832 L^2 \pi ^4 A^4+3600 L^4 \pi ^2 A^2+2160 L^6+\sqrt{-7962624000 \pi ^{12} A^{12}-8626176000 L^2 \pi ^{10} A^{10}+717410304 L^4 \pi ^8 A^8+3308138496 L^6 \pi ^6 A^6+911879424 L^8 \pi ^4 A^4+17252352 L^{10} \pi ^2 A^2+4672512 L^{12}}}}{15 \sqrt[3]{2}}+\frac{9 L^2}{25}-\frac{4}{15} \left(10 \pi ^2 A^2+3 L^2\right)+\frac{4 \sqrt[3]{2} \left(640 \pi ^4 A^4-246 L^2 \pi ^2 A^2-3 L^4\right)}{15 \sqrt[3]{-243200 \pi ^6 A^6+176832 L^2 \pi ^4 A^4+3600 L^4 \pi ^2 A^2+2160 L^6+\sqrt{-7962624000 \pi ^{12} A^{12}-8626176000 L^2 \pi ^{10} A^{10}+717410304 L^4 \pi ^8 A^8+3308138496 L^6 \pi ^6 A^6+911879424 L^8 \pi ^4 A^4+17252352 L^{10} \pi ^2 A^2+4672512 L^{12}}}}}-\frac{1}{2} \sqrt{-\frac{\sqrt[3]{-243200 \pi ^6 A^6+176832 L^2 \pi ^4 A^4+3600 L^4 \pi ^2 A^2+2160 L^6+\sqrt{-7962624000 \pi ^{12} A^{12}-8626176000 L^2 \pi ^{10} A^{10}+717410304 L^4 \pi ^8 A^8+3308138496 L^6 \pi ^6 A^6+911879424 L^8 \pi ^4 A^4+17252352 L^{10} \pi ^2 A^2+4672512 L^{12}}}}{15 \sqrt[3]{2}}+\frac{18 L^2}{25}-\frac{8}{15} \left(10 \pi ^2 A^2+3 L^2\right)-\frac{4 \sqrt[3]{2} \left(640 \pi ^4 A^4-246 L^2 \pi ^2 A^2-3 L^4\right)}{15 \sqrt[3]{-243200 \pi ^6 A^6+176832 L^2 \pi ^4 A^4+3600 L^4 \pi ^2 A^2+2160 L^6+\sqrt{-7962624000 \pi ^{12} A^{12}-8626176000 L^2 \pi ^{10} A^{10}+717410304 L^4 \pi ^8 A^8+3308138496 L^6 \pi ^6 A^6+911879424 L^8 \pi ^4 A^4+17252352 L^{10} \pi ^2 A^2+4672512 L^{12}}}}-\frac{\frac{216 L^3}{125}-\frac{48}{25} \left(10 \pi ^2 A^2+3 L^2\right) L+\frac{48}{5} \left(L^2-2 A^2 \pi ^2\right) L}{4 \sqrt{\frac{\sqrt[3]{-243200 \pi ^6 A^6+176832 L^2 \pi ^4 A^4+3600 L^4 \pi ^2 A^2+2160 L^6+\sqrt{-7962624000 \pi ^{12} A^{12}-8626176000 L^2 \pi ^{10} A^{10}+717410304 L^4 \pi ^8 A^8+3308138496 L^6 \pi ^6 A^6+911879424 L^8 \pi ^4 A^4+17252352 L^{10} \pi ^2 A^2+4672512 L^{12}}}}{15 \sqrt[3]{2}}+\frac{9 L^2}{25}-\frac{4}{15} \left(10 \pi ^2 A^2+3 L^2\right)+\frac{4 \sqrt[3]{2} \left(640 \pi ^4 A^4-246 L^2 \pi ^2 A^2-3 L^4\right)}{15 \sqrt[3]{-243200 \pi ^6 A^6+176832 L^2 \pi ^4 A^4+3600 L^4 \pi ^2 A^2+2160 L^6+\sqrt{-7962624000 \pi ^{12} A^{12}-8626176000 L^2 \pi ^{10} A^{10}+717410304 L^4 \pi ^8 A^8+3308138496 L^6 \pi ^6 A^6+911879424 L^8 \pi ^4 A^4+17252352 L^{10} \pi ^2 A^2+4672512 L^{12}}}}}}}$

The above just makes the point that the solution can't be written by hand (or by mine at least).

So my question is, can I represent the solution using an easily-written function of $A$ and $L$ (for instance, as a infinite summation)?

$\endgroup$
  • 2
    $\begingroup$ It would be helpful if you posted the code for the equation (or for Solve). $\endgroup$ – Michael E2 Aug 20 '14 at 10:34
  • $\begingroup$ Solve[L == (3 W)/2 + (3 Sqrt[4 A^2 Pi^2 + W^2])/2 - Sqrt[6 A^2 Pi^2 + 3 W^2 + 5 W Sqrt[4 A^2 Pi^2 + W^2]]/Sqrt[2], W] $\endgroup$ – J.D'Almbert Aug 20 '14 at 10:36
  • 4
    $\begingroup$ Aren't you impressed it does find a solution? :-) $\endgroup$ – chris Aug 20 '14 at 10:45
  • $\begingroup$ Of course, but I would prefer it if I could write it on my whiteboard. $\endgroup$ – J.D'Almbert Aug 20 '14 at 10:47
  • $\begingroup$ Did you try a Simplify or FullSimplify? Some assumptions might help with those, too. $\endgroup$ – Yves Klett Aug 20 '14 at 10:54
13
$\begingroup$

It seems me that the answers of mathe and Yves Klett do not meet expectations of the author. The latter is as much as I have got it, to have a short analytical expression for the solution. Probably the author has an intention to use the result further in some analytical calculations, or to do something comparable. Am I right?

If yes, one should first of all be clear that what is already found is the exact solution, which is what it is. If you need the exact solution, you can only try to somewhat simplify it, as Yves Klett did, and after the simplification is done, that's it.

Another story, if you agree to have an approximate solution, which is expressed by a simple analytical formula. In that case I can contribute as follows. Here is your equation:

eq1 = L == (3 W)/2 + (3 Sqrt[4 A^2 Pi^2 + W^2])/2 -Sqrt[6 A^2
Pi^2 + 3 W^2 + 5 W Sqrt[4 A^2 Pi^2 + W^2]]/Sqrt[2]

First let us simplify a bit your equation by changing variables:

 eq2 = Simplify[
  eq1 /. {W -> 2 \[Pi]*A*x, L -> 2 \[Pi]*A*u}, {x > 0, A > 0}]

(*   3 (x + Sqrt[1 + x^2]) == 2 u + Sqrt[3 + 6 x^2 + 10 x Sqrt[1 + x^2]]   *)

Now let us consider the variable xas a new unknown and u as a parameter and solve with respect to x.

slX = Solve[eq2, x];

Its solutions are still too cumbersome. For this reason I do not give them below. One can make sure that there are four of them:

 slX // Length

(*  4  *)

And visualize them

    Plot[{slX[[1, 1, 2]], slX[[2, 1, 2]], slX[[3, 1, 2]], 
  slX[[4, 1, 2]]}, {u, 0, 4}, PlotStyle -> {Red, Blue, Green, Brown}]

giving the following: enter image description here

Now one can approximate any of these solutions by some simple function. I will give the example with the first solution. First let us make a list out of it:

    lst = Select[Table[{u, slX[[1, 1, 2]]}, {u, 0.6, 1, 0.003}], 
   Im[#[[2]]] == 0 &];

Second, let us approximate it by a simple model:

model = a + b/(c + u);
ff = FindFit[lst, model, {a, b, {c, -0.63}}, u]
Show[{
  ListPlot[lst, Frame -> True, 
   FrameLabel -> {Style["u", 16, Italic], Style["x", 16, Italic]}],
  Plot[model /. ff, {u, 0.63, 1}, PlotStyle -> Red]
    }]

The outcome is the values of the model parameters:

(*    {a -> -0.418378, b -> 0.0290875, c -> -0.549429}   *)

and the plot enabling one to visually estimate the quality of the approximation:

enter image description here

Here the blue points come from the list, and the solid red line - from the approximation. Have fun!

|improve this answer|||||
$\endgroup$
  • 2
    $\begingroup$ I will have fun and learn a lot. You saved a sad day. $\endgroup$ – user9660 Aug 20 '14 at 15:39
12
$\begingroup$

I've fiddled with this on and off for a while now, hesitating to decide whether it was worth posting since another answer has already been accepted. The undocumented function, Experimental`OptimizeExpression, can be used to break down the solutions algebraically into common subexpressions, and it seemed like an approach worth sharing. On the other hand, this equation is essentially equivalent to a quartic polynomial:

Quit[]

eqn = L == (3 W)/2 + (3 Sqrt[4 A^2 Pi^2 + W^2])/2 - 
    Sqrt[6 A^2 Pi^2 + 3 W^2 + 5 W Sqrt[4 A^2 Pi^2 + W^2]]/Sqrt[2];
sols = W /. Solve[eqn, W];
poly = Collect[5 Times @@ (W - sols) // Expand // Simplify, W]
(*
  L^4 - 24 A^2 L^2 π^2 + 36 A^4 π^4 + (-6 L^3 + 12 A^2 L π^2) W +
   (6 L^2 + 20 A^2 π^2) W^2 - 6 L W^3 + 5 W^4
*)

The solutions turn out to resemble the standard quartic formula. Indeed, it might be just as easy to build up the solutions from the formula by hand from the polynomial derived below (perhaps using Mathematica to keep track of the algebraic steps). The expression will still be rather complicated due to the nature of the quartic formula and the coefficients, even if they appear to have some symmetry.

Different purposes might be fulfilled by being able to write expressions for the roots. Presumably the general goal would be to illuminate elements of the problem, but all we are given is an algebraic equation. In some cases an analytic approach might be more appropriate than an algebraic approach, or vice versa.

Auxiliary functions

Set up the equation and solutions; the solutions may be used to construct a polynomial with the same roots (the coefficient 5 is discovered by inspection).

The function Experimental`OptimizeExpression returns an expression of the form

Experimental`OptimizedExpression[Block[{vars}, var1 = val1; <>; varn = valn; expr]]

The variables have the form Compile`$nnn, where nnn represents a serial number, and represent subexpressions; if a subexpression appears more than once, it will be represented by the same variable. Unfortunately, the serial number increases throughout a session and the starting number depends on what evaluations have been done. (Execute Quit[] above to get the same numbering -- unless the numbering is version/system dependent.) The expression expr represents the optimized expression in terms of the variables. Preceding it, the variables are initialized. From this we can construct auxiliary functions for exploring the expression.

Experimental`OptimizeExpression takes an OptimizationLevel option and may be set to 0, 1, or 2. Subexpressions are stored in the returned Experimental`OptimizeExpression in a held Block in the form Compile`$nnn = expr. We can turn these Set expressions into Rule expressions that can be used to expand a given subexpression in terms of the next level of subexpressions. One can also replace the last expression inside Block with an arbitrary expression in terms of Compile`$nnn variable and it will be evaluated in terms of the subexpressions of the optimized expression.

optexpr = Experimental`OptimizeExpression[sols, OptimizationLevel -> 2];

(* get the initialization in terms of Rule *)
optrules = Most[(optexpr /. {Set -> Rule, CompoundExpression -> List})[[1, 2]]];

(* convert between Compile`$nnn symbol and the number nnn *)
compileSym = ToExpression["Compile`$" <> ToString[#]] &;
compileSymNo = ToExpression@StringDrop[SymbolName[#], 1] &;

(* get the range of the serial numbers of the variables *)
{minCompileNumber, 
   maxCompileNumber} = 
  Through[{Min, Max}[
    Cases[optexpr, 
     x_Symbol /; Context[x] === "Compile`" :> compileSymNo[x](*ToExpression@
     StringDrop[SymbolName[x],1]*), Infinity]]];

(* evaluate an expression in terms of Compile`$nnn variables *)
evalCompileExpr = ReplacePart[Function @@ optexpr, {1, -1, -1} :> Slot[1]];

The following shows the structure of the four roots determined by Experimental`OptimizeExpression. It reveals the typical structure of the roots of a quartic equation.

optoutput = optexpr[[1, -1, -1]]
(*
{Compile`$1 + Compile`$57 - Compile`$71/2, 
 Compile`$1 + Compile`$57 + Compile`$71/2, 
 Compile`$1 + Compile`$76 - Compile`$79/2, 
 Compile`$1 + Compile`$76 + Compile`$79/2}
*)

Using the functions

Executing expr /. optrules will expand the variables one step. What steps to take requires some judgment. If we expand optoutput, we see the structure of the quartic formula begin to unfold.

optoutput /. optrules
(*
{(3 L)/10 - Compile`$56/2 - Sqrt[Compile`$70]/2, (3 L)/10 - Compile`$56/2 + 
  Sqrt[Compile`$70]/2, (3 L)/10 + Compile`$56/2 - Sqrt[Compile`$78]/2, (3 L)/
  10 + Compile`$56/2 + Sqrt[Compile`$78]/2}
*)

{Compile`$70, Compile`$78} /. optrules
(*
{Compile`$58 + Compile`$59 + Compile`$60 + Compile`$61 + Compile`$69, 
 Compile`$58 + Compile`$59 + Compile`$60 + Compile`$61 + Compile`$77}
*)

{Compile`$69, Compile`$77} /. optrules
(*
{-((Compile`$67 Compile`$68)/4), (Compile`$67 Compile`$68)/4}
*)

The above calculations show we can write the solutions in the form

W -> 3 L / 10 ± d1 ± Sqrt[d2 ± d3] / 2

where

d1 = Compile`$56 / 2

d2 = Compile$58 + Compile`$59 + Compile$60 + Compile$61 d3 = (Compile`$67 Compile$68) / 4

and the first and third ± signs agree.

One can examine the actual expressions with evalCompileExpr, but, as I said, without the context of the problem, it's hard to see anything important lurking in the expressions.

We can break down the solution into bit-size pieces -- well, whiteboard-size pieces. One can see there is a large cube root that is repeated and larger square root. We can get them and replace with them with new variables Q and R as follows:

rootTerms = {Compile`$56/2, 
   Compile`$58 + Compile`$59 + Compile`$60 + Compile`$61, (Compile`$67 Compile`$68)/4};

simpRT = Simplify /@ evalCompileExpr[rootTerms];
q = First@Cases[simpRT, Power[Except[_?NumberQ], 1/3], Infinity];
Q -> q
cbrt = {q -> Q, 1/q -> 1/Q};
r = First@Cases[simpRT /. cbrt, Power[Except[_?NumberQ], 1/2], Infinity];
R -> r
sqrt = {r -> R, 1/r -> 1/R};
Thread[{d1, d2, d3} -> simpRT /. cbrt /. sqrt]
(*
Q -> (135 L^6 + 225 A^2 L^4 π^2 + 11052 A^4 L^2 π^4 - 15200 A^6 π^6 +
       3 Sqrt[3] Sqrt[(13 L^2 + 24 A^2 π^2)^2 (4 L^8 + 767 A^4 L^4 π^4 - 2000 A^8 π^8)])^(1/3)

R -> Sqrt[27 L^2 - 20 (3 L^2 + 10 A^2 π^2) -
      (10 (3 L^4 + 246 A^2 L^2 π^2 - 640 A^4 π^4))/Q + 10 Q]

{d1 -> R/(10 Sqrt[3]), 
 d2 -> 1/75 (54 L^2 - 40 (3 L^2 + 10 A^2 π^2) +
        (10 (3 L^4 + 246 A^2 L^2 π^2 - 640 A^4 π^4))/Q - 10 Q), 
 d3 -> (6 Sqrt[3] (29 L^3 - 200 A^2 L π^2))/(25 R)}
*)

These together with the expression of W above in terms of d1, d2, and d3 present the complete solution. Aside from some minor simplifications, one can see that d2 may be written

d2 -> 1/75 (81 L^2 - 60 (3 L^2 + 10 A^2 π^2) - R^2) // Factor
(*
d2 -> 1/75 (-99 L^2 - 600 A^2 π^2 - R^2)
*)

Homogenization

Here is another way to look at the solutions. It is not amenable to written presentation but it is a nice way to look at the problem. With a change of variables, we can transform the equation into a homogeneous polynomial poly0 of three variables. Dilations then act on the solution set and one dimension can be factored out. In other words all solutions may be obtained from scaling a given cross-section of the surface poly0 == 0.

Here are transformations for converting between poly and poly0.

homogenize = {A :> Sqrt[α]/(Sqrt[2] Pi), L -> λ/Sqrt[α], W -> Ω/Sqrt[α]};
dehomogenize = First@Solve[{A, L, W} == ({A, L, W} /. homogenize), {α, λ, Ω}]
(*
{α -> 2 A^2 π^2, λ -> Sqrt[2] A L π, Ω -> Sqrt[2] A π W}
*)

eqn0 = eqn /. homogenize // Simplify;
sols0 = Ω /. Solve[eqn0, Ω];
poly0 = Collect[5 Times @@ (Ω - sols0) // Expand // Simplify, Ω]
poly == ((W/Ω)^4 poly0 /. dehomogenize) // Expand
(*
9 α^4 - 12 α^2 λ^2 + λ^4 + (6 α^2 λ - 6 λ^3) Ω + (10 α^2 + 6 λ^2) Ω^2 - 6 λ Ω^3 + 5 Ω^4

True
*)

Any solution (for Ω or A π W) to poly0 == 0 may be obtained by dilation (scaling) of a plane section of the surface poly0 == 0. Below the relationships of each of two sections to the solution set are shown, with the mesh lines showing the dilation of the boundary curve.

sectλ = Show[
   ContourPlot3D[
    poly0 == 0, {α, -1.2, 1.2}, {λ, -1, 1}, {Ω, -1, 1},
    MeshFunctions -> {ArcTan[#1, #2] &, #2 &}, 
    PlotPoints -> 20, AxesLabel -> Automatic],
   ParametricPlot3D[
    Thread[{α, λ, sols0}] /. λ -> 1 // Evaluate, {α, -1.2, 1.2},
    PlotPoints -> 100, 
    PlotStyle -> (Directive[Thickness[0.01], #] & /@ {Red, Blue, Magenta, Darker@Green})]
   ];

sectα = Show[
   ContourPlot3D[
    poly0 == 0, {α, -1, 1}, {λ, -4, 4}, {Ω, -3, 3},
    MeshFunctions -> {ArcTan[#1, #2] &, #1 &}, PlotPoints -> 20, 
    AxesLabel -> Automatic],
   ParametricPlot3D[
    Thread[{α, λ, sols0}] /. α -> 1 // Evaluate, {λ, -4, 4},
    PlotPoints -> 100, 
    PlotStyle -> (Directive[Thickness[0.01], #] & /@ {Red, Blue, Magenta, Darker@Green})],
   BoxRatios -> {1, 4, 3}
   ];

GraphicsRow[{sectλ, sectα}]

Mathematica graphics

|improve this answer|||||
$\endgroup$
8
$\begingroup$
Solve[L == (3 W)/2 + 3/2 Sqrt[4 A^2 Pi^2 + W^2] - Sqrt[
   6 A^2 Pi^2 + 3 W^2 + 5 W Sqrt[4 A^2 Pi^2 + W^2]]/Sqrt[2], W, 
 Quartics -> False]

Mathematica graphics

or

Solve[L == (3 W)/2 + 3/2 Sqrt[4 A^2 Pi^2 + W^2] - Sqrt[
   6 A^2 Pi^2 + 3 W^2 + 5 W Sqrt[4 A^2 Pi^2 + W^2]]/Sqrt[2], W, Reals]
|improve this answer|||||
$\endgroup$
5
$\begingroup$

One shotgun approach is to sic Simplify or FullSimplify onto your solution:

sol1 = Solve[
   L == (3 W)/2 + (3 Sqrt[4 A^2 Pi^2 + W^2])/2 - 
     Sqrt[6 A^2 Pi^2 + 3 W^2 + 5 W Sqrt[4 A^2 Pi^2 + W^2]]/Sqrt[2], W];

sol2 = Simplify[sol1];

LeafCount /@ {sol1, sol2}
ByteCount /@ {sol1, sol2}

{3849, 3077}

{111720, 92840}

(Note: A FullSimplify attempt was stopped after several hours)

Using additional assumptions may help the simplification substantially, too.

|improve this answer|||||
$\endgroup$
  • 1
    $\begingroup$ @m_goldberg "unto" had that biblical touch... $\endgroup$ – Yves Klett Aug 20 '14 at 11:05
  • $\begingroup$ Indeed, but it's an archaic/poetic form of "to" or "until". The idiom is "sic your dog on/onto trespassers", not "sic your dog to/until trespassers" $\endgroup$ – m_goldberg Aug 20 '14 at 11:11
  • $\begingroup$ @m_goldberg eek! Consider me properly abashed :D $\endgroup$ – Yves Klett Aug 20 '14 at 11:18
  • $\begingroup$ Mission accomplished :D $\endgroup$ – m_goldberg Aug 20 '14 at 11:19
  • $\begingroup$ @m_goldberg Unlike my FullSimplify, which is still chugging away merrily. $\endgroup$ – Yves Klett Aug 20 '14 at 11:22

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.