0
$\begingroup$

I appear not to be able to find a way to simplify the sums of fractions like the following example to their shortest representation. For me shorteste representation means, to have as few as possible repeting terms. As a proxy to this I use LeafCount, and thus want it minimized for expressions consisting of sums of fractions. FullSimplify fails to do much, just as using PowerExpand as additional TransformationFunction. Watch for yourself:

Here is the expression:

(-3 a - 2 a^3 + 4 Sqrt[1 + a^2] (5 - 9 Log[2]) + 
 4 a^2 Sqrt[1 + a^2] (5 - 9 Log[2]) + 
 12 (1 + a^2)^(3/2) Log[1 + Sqrt[1 + 1/a^2]] - 
 6 (4 (Sqrt[1 + a^2] - a (2 + a^2 - a Sqrt[1 + a^2])) Log[a] + 
    a Log[1 + a^2]))/(12 (1 + a^2)^(3/2) Sqrt[2 π])

$\frac{-2 a^3+4 \sqrt{a^2+1} a^2 (5-9 \log (2))+12 \left(a^2+1\right)^{3/2} \log \left(\sqrt{\frac{1}{a^2}+1}+1\right)-6 \left(4 \left(\sqrt{a^2+1}-a \left(a^2-\sqrt{a^2+1} a+2\right)\right) \log (a)+a \log \left(a^2+1\right)\right)+4 \sqrt{a^2+1} (5-9 \log (2))-3 a}{12 \sqrt{2 \pi } \left(a^2+1\right)^{3/2}}$

You can see that there are many repeating terms, and it is obvious that this cannot be the shortest form. And the following commands will not do anything to better the situation:

FullSimplify[%, Assumptions -> {a \[Element] Reals, a > 0}]

or

FullSimplify[%, Assumptions -> {a \[Element] Reals, a > 0},
    TransformationFunctions -> {Automatic, PowerExpand}]

or even

FullSimplify[Together[Expand[%]], Assumptions -> {a \[Element] Reals, a > 0}]

My bet of where the issue is, is currently on Together. It does something suboptimal (in terms of LeafCount):

a/e + b/e + c/f + d/f // Together

yields:

(c e + d e + a f + b f)/(e f)

this thing can be further simplified with FullSimplify to the optimal result:

(a + b)/e + (c + d)/f

However this does obviously not work for my expression, I guess Together increases the LeafCount so much, that FullSimplify simply discards its intermediate results and goes without it.

Edit: I just found that there is some simplification done with:

FullSimplify[Apart[%]]

which yields the somewhat simplified expression:

(12 Log[1 + Sqrt[1 + 1/a^2]] - (
 3 a + 2 a^3 - 20 (1 + a^2)^(3/2) + 36 (1 + a^2)^(3/2) Log[2] - 
  48 a Log[a] - 24 a^3 Log[a] + 24 (1 + a^2)^(3/2) Log[a] + 
  6 a Log[1 + a^2])/(1 + a^2)^(3/2))/(12 Sqrt[2 \[Pi]])

$\frac{12 \log \left(\sqrt{\frac{1}{a^2}+1}+1\right)-\frac{2 a^3-24 a^3 \log (a)-20 \left(a^2+1\right)^{3/2}+6 a \log \left(a^2+1\right)+24 \left(a^2+1\right)^{3/2} \log (a)+36 \left(a^2+1\right)^{3/2} \log (2)+3 a-48 a \log (a)}{\left(a^2+1\right)^{3/2}}}{12 \sqrt{2 \pi }}$

However the result is still not the shortest form, there is still obviously a simplier expresion possible.

Improve this question
$\endgroup$
3
  • $\begingroup$ Welcome to Mathematica.SE! I hope you will become a regular contributor. To get started, 1) take the introductory Tour now, 2) when you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge, 3) remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign, and 4) give help too, by answering questions in your areas of expertise. $\endgroup$
    – bbgodfrey
    May 27, 2015 at 11:00
  • $\begingroup$ Hey, thanks. Yes I am new to this page, as a contributor, however I have already been reading a lot previously. $\endgroup$
    – erazortt
    May 27, 2015 at 12:26
  • $\begingroup$ Can you describe the transformation you wish to perform on this expression? $\endgroup$
    – Mr.Wizard
    May 27, 2015 at 19:27

2 Answers 2

Reset to default
1
$\begingroup$

This is your expression:

expr = (-3 a - 2 a^3 + 4 Sqrt[1 + a^2] (5 - 9 Log[2]) + 
4 a^2 Sqrt[1 + a^2] (5 - 9 Log[2]) + 
12 (1 + a^2)^(3/2) Log[1 + Sqrt[1 + 1/a^2]] - 
6 (4 (Sqrt[1 + a^2] - a (2 + a^2 - a Sqrt[1 + a^2])) Log[a] + 
   a Log[1 + a^2]))/(12 (1 + a^2)^(3/2) Sqrt[2 \[Pi]]);

Let us make a variable change:

    expr1 = expr /. a -> Sqrt[x - 1]

(*   (1/(12 Sqrt[2 \[Pi]] x^(
 3/2)))(-3 Sqrt[-1 + x] - 2 (-1 + x)^(3/2) + 
  4 Sqrt[x] (5 - 9 Log[2]) + 4 (-1 + x) Sqrt[x] (5 - 9 Log[2]) + 
  12 x^(3/2) Log[1 + Sqrt[1 + 1/(-1 + x)]] - 
  6 (4 (Sqrt[x] - Sqrt[-1 + x] (1 - Sqrt[-1 + x] Sqrt[x] + x)) Log[
       Sqrt[-1 + x]] + Sqrt[-1 + x] Log[x]))   *)

and simplify it:

      expr2 = Simplify[expr1, 0 < x < 1]

 (*   (1/(12 Sqrt[2 \[Pi]] x^(
     3/2)))(-Sqrt[-1 + x] - 2 Sqrt[-1 + x] x + 20 x^(3/2) - 
      36 x^(3/2) Log[2] + 
      12 (Sqrt[-1 + x] + Sqrt[-1 + x] x - x^(3/2)) Log[-1 + x] - 
      6 Sqrt[-1 + x] Log[x] + 12 x^(3/2) Log[1 + Sqrt[x/(-1 + x)]]) *)

One can observe that the term {4,5}contains lots of factors like Sqrt[-1 + x]and x^(3/2). The idea may be to factorize them, but first to expand this term:

     expr3 = MapAt[Expand, expr2, {4, 5}]

(*    (1/(12 Sqrt[2 \[Pi]] x^(
     3/2)))(-Sqrt[-1 + x] - 2 Sqrt[-1 + x] x + 20 x^(3/2) - 
      36 x^(3/2) Log[2] + 12 Sqrt[-1 + x] Log[-1 + x] + 
      12 Sqrt[-1 + x] x Log[-1 + x] - 12 x^(3/2) Log[-1 + x] - 
      6 Sqrt[-1 + x] Log[x] + 12 x^(3/2) Log[1 + Sqrt[x/(-1 + x)]])   *)

Now let us factorize:

     expr4 = MapAt[Collect[#, {Sqrt[-1 + x], x^(3/2)}] &, expr3, {4}]

(*    (1/(12 Sqrt[2 \[Pi]] x^(
     3/2)))(Sqrt[-1 + 
        x] (-1 + 12 Log[-1 + x] + x (-2 + 12 Log[-1 + x]) - 6 Log[x]) + 
      x^(3/2) (20 - 36 Log[2] - 12 Log[-1 + x] + 
         12 Log[1 + Sqrt[x/(-1 + x)]]))   *)

Now there are logarithms in the positions {{4, 1, 2}, {4, 2, 2}}those may be collected. For this end let us introduce a function

    collectLog[expr_] := Module[{rule1a, rule1b, rule2, g, a, b, x},
   rule1a = Log[a_] + Log[b_] -> Log[a*b];
   rule1b = Log[a_] - Log[b_] -> Log[a/b];
   rule2 = x_*Log[a_] -> Log[a^x];
   g[x_] := x /. rule1a /. rule1b /. rule2;
   FixedPoint[g, expr]
   ];

That should be applied to the terms in question:

 expr5 = MapAt[collectLog, expr4, {{4, 1, 2}, {4, 2, 2}}]

(*  (Sqrt[-1 + 
   x] (-1 + x (-2 + Log[(-1 + x)^12]) + Log[(-1 + x)^12/x^6]) + 
 x^(3/2) (20 + 
    Log[(1 + Sqrt[x/(-1 + x)])^12/(
     68719476736 (-1 + x)^12)]))/(12 Sqrt[2 \[Pi]] x^(3/2))  *)

and finally let us return to the initial notations: 

     expr5 /. x -> 1 + a^2 // Simplify[#, a > 0] &

(*   (a (-1 + (1 + a^2) (-2 + 24 Log[a]) + Log[a^24/(1 + a^2)^6]) + (1 + 
    a^2)^(3/2) (20 + 
    Log[(a + Sqrt[1 + a^2])^12/(68719476736 a^36)]))/(12 (1 + a^2)^(
 3/2) Sqrt[2 \[Pi]])   *)

That is a bit shorter, is not it? I am not quite sure that this is what you wanted, but if yes, have fun!

Improve this answer
$\endgroup$
4
  • $\begingroup$ Hehe you seem to have answered while I was typing my answer. Yes, what you do does help in this case. However my expression was just an example for expressions I work with. The transformations you do are hand picked for this instance and they do not seem to be easily automated for expressions very different to my example. I was after some general solution. $\endgroup$
    – erazortt
    May 28, 2015 at 11:38
  • 1
    $\begingroup$ @erazortt Mma does not always make a simplification that would satisfy you (me, him...). This is a known fact discussed here many times. So if you are not satisfied by what Mma did by a combination of standard operators, you have to look for a way to transform it, so to say, personally. There are usually several ways to do that, and mine is only one of them. Generally, however, here is exactly the place, where science transforms itself into art. $\endgroup$
    – Alexei Boulbitch
    May 28, 2015 at 14:00
  • $\begingroup$ Perhaps black art even ;) And yes of course, there are many ways getting to Rome, as we say here. I do not object your way. $\endgroup$
    – erazortt
    May 28, 2015 at 14:49
  • $\begingroup$ @erazortt Just to comment on your words: "my expression was just an example for expressions I work with". Yes, this is understood. Consider my answer also just as an example of what can be done. Giving this example I kept to actions only using the main body of Mma, without using foreign packages. The latter might make life much easier. $\endgroup$
    – Alexei Boulbitch
    May 28, 2015 at 15:12
1
$\begingroup$

Ok, so first of all sorry if I was not clear enough with my questions. Anyway, I went back to the drawing board last night, and I followed the idea that perhaps the functions Together and Apart tend to exaggerate what they do in the sense of LeafCount. Take the follwing expression:

a/e + b/e + c/f + d/f + Log[x]

Together produces something which has too many unnecessary repetitions of variables because it tries to put anything on one fraction:

(c e + d e + a f + b f + e f Log[x])/(e f)

While Apart produces a somewhat better expression which howevever still has too many repetions:

(c e + d e + a f + b f)/(e f) + Log[x]

Interestingly if the Log[x] was left out, Apart would do exactly the right thing in this example but it seems it gets confused by the Log.

So what I came up with last night was a function that takes all fractions of a sum and tests which terms to take Together in order to reach smallest LeafCount. This function can be used in all circumstances when there are fractions which should be compressed to a from which minimizes operations and term repetitions. Taking this as an addition to TransformationsFunctions in (Full-)Simplify and the results are marvelous. 

Clear[myTogether];
myTogether`inside = False;
Options[myTogether] = Options[Together]
myTogether[expr_, opt : OptionsPattern[]] := 
  myTogether[expr, LeafCount[expr], opt];
myTogether[expr_, count_, opt : OptionsPattern[]] := Block[
  {bestPermCount, bestPerm, sumListActiveLength, sumList, 
   sumListLength, numTable, permList, currPerm, currCount}, {};
  If[MatchQ[expr, _Plus], 0, Return[expr]];
  bestPermCount = count;
  bestPerm = expr;
  sumListActiveLength = 0;
  sumList = {};
  Scan[(If[TrueQ[Denominator[#] == 1],
       AppendTo[sumList, #],
       (PrependTo[sumList, #]; sumListActiveLength++)];
     ) &, List @@ bestPerm];
  If[sumListActiveLength < 2, Return[expr]];
  sumListLength = Length[sumList];
  numTable = Table[i, {i, 1, sumListActiveLength}];
  permList = Permutations[numTable, {2}];
  numTable = Table[i, {i, 1, sumListLength}];
  myTogether`inside = True;
  Do[
   currPerm = Together[Plus @@ Part[sumList, permList[[i]]], opt]
     + Plus @@ Part[sumList, Complement[numTable, permList[[i]]]];
   currCount = LeafCount[currPerm];
   If[currCount < bestPermCount, (
     bestPermCount = currCount;
     bestPerm = currPerm;
     )]
   , {i, 1, Length[permList]}
   ];
  myTogether`inside = False;
  If[Length[List @@ bestPerm] < sumListLength, 
   myTogether[bestPerm, bestPermCount, opt], bestPerm]
  ]

Doing myTogether[Expand[%]] for my initial expression which had a LeafCount of 135 I now get something with a LeafCount of 95:

-((-5 + 9 Log[2] - 3 Log[1 + Sqrt[1 + 1/a^2]])/(3 Sqrt[2 \[Pi]])) - 
 Sqrt[2/\[Pi]] Log[a] + (-3 a - 2 a^3 + 48 a Log[a] + 24 a^3 Log[a] - 
  6 a Log[1 + a^2])/(12 (1 + a^2)^(3/2) Sqrt[2 \[Pi]])

$-\frac{-3 \log \left(\sqrt{\frac{1}{a^2}+1}+1\right)-5+9 \log (2)}{3 \sqrt{2 \pi }}+\frac{-2 a^3+24 a^3 \log (a)-6 a \log \left(a^2+1\right)-3 a+48 a \log (a)}{12 \sqrt{2 \pi } \left(a^2+1\right)^{3/2}}-\sqrt{\frac{2}{\pi }} \log (a)$

This is not bad, but I can get better. Doing a Simplify[%, TransformationFunctions -> {Automatic, myTogether}] on the initial expression compresses the expression further, decreasing the LeafCount to 71 and the number of repeated terms down to a minimum.

(-4 (-5 + Log[512] - 3 Log[1 + Sqrt[1 + 1/a^2]] + 6 Log[a]) + (
 a (-3 - 2 a^2 + 24 (2 + a^2) Log[a] - 6 Log[1 + a^2]))/(1 + a^2)^(
 3/2))/(12 Sqrt[2 \[Pi]])

$\frac{\frac{a \left(-2 a^2+24 \left(a^2+2\right) \log (a)-6 \log \left(a^2+1\right)-3\right)}{\left(a^2+1\right)^{3/2}}-4 \left(-3 \log \left(\sqrt{\frac{1}{a^2}+1}+1\right)+6 \log (a)-5+\log (512)\right)}{12 \sqrt{2 \pi }}$

The only question remaining for me is, if there is perhaps a faster way to do what I do inside this function. It takes all possible combinations of 2 fractions out of the sum and checks if applying Together (actually Apart also seems to work) on them decreases the LeafCount. The combination of two terms which decreases the LeafCount most is taken and then the function calles itself to find the next two terms. This is probably not the fastest way of doing it, I don't know.

Improve this answer
$\endgroup$
1
  • $\begingroup$ Would you please summarize your desired transformation in an update to the question? $\endgroup$
    – Mr.Wizard
    Jun 1, 2015 at 5:54

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.