Simplify large sum of fractions to shortest representation

Question

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.

Answer 1

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!

Answer 2

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.