I want to have common subexpression elimination of comlicated functions where the elimination is done by factoring out the expressions. The result is not to be digested by a compiler, it should remain symbolic.
I want this to work in general, without choosing things by hand.

As an example of what I want to do, take to following 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])

```

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

This will not change by doing `FullSimplify[ExpandAll[%], Assumptions -> _Symbol \[Element] Reals]`.

What I am after is to transform this expression to something where the complicated terms (e.g. measured in LeafCount) are nested.
What I came up with until now is something which mostly works. However in terms of programming it is probably the ugliest function written in recent human history. I would like to ask if somebody has an idea how to do things nicer. Perhaps using `OptimizeExpression` is actually the wrong thing to do.

```
nestComplicatedTerms[x_] := Block[
  {expr, compiled, exprList, exprList2, countList}, {};
  compiled = 
   Experimental`OptimizeExpression[x, OptimizationLevel -> 2];
  compiled = Map[Hold, compiled, {2}][[1, 2]];
  compiled = ToString[InputForm[compiled]];
  compiled = 
   StringReplace[
    compiled, {"=" -> "->", ";" -> ",", "Hold" -> "List"}];
  exprList = ToExpression[compiled];
  exprList2 = exprList;
  countList = Table[(
     exprList = exprList /. exprList[[i]];
     {exprList2[[i]][[1]], 
      LeafCount[exprList[[i]][[2]]]*
       Boole[Count[exprList2[[-1]], exprList2[[i]][[1]], {-1}] > 0]}
     ), {i, 1, Length[exprList] - 1}];
  countList = SortBy[countList, -Last[#] &];
  countList = Table[countList[[i]][[1]], {i, 1, Length[countList]}];
  exprList = exprList2;
  expr = HornerForm[exprList[[-1]], countList];
  Do[(
    expr = expr /. exprList[[i]];
    exprList = exprList /. exprList[[i]];
    ), {i, 1, Length[exprList] - 1}];
  expr
  ]

```

What it does is to first produce the output from `OptimizeExpression`. Then comes the ugly step. The output is transformed to a string, replacing some characters and then transfomed back to an expression. I had to do this, because I was unable to extract the replacement rules without actually replacing the variables in the function.

This is how the output from `OptimizeExpression` looks like:

```
Experimental`OptimizedExpression[
 Block[{Compile`$938, Compile`$948, Compile`$954, Compile`$955, 
   Compile`$956, Compile`$957, Compile`$958, Compile`$961, 
   Compile`$962, Compile`$963, Compile`$964},
  Compile`$938 = a^2; 
      Compile`$948 = a Compile`$938;
  Compile`$954 = 1 + Compile`$938; 
      Compile`$955 = Sqrt[Compile`$954];
  Compile`$956 = Log[2]; 
      Compile`$957 = -9 Compile`$956;
  Compile`$958 = 5 + Compile`$957; 
      Compile`$961 = Compile`$955 Compile`$954; 
      Compile`$962 = 1/Compile`$938;
  Compile`$963 = 1 + Compile`$962; 
      Compile`$964 = Sqrt[Compile`$963];
  -3 a - 2 Compile`$948 + 
       4 Compile`$955 Compile`$958 + 
   4 Compile`$938 Compile`$955 Compile`$958 + 
   12 Compile`$961 Log[1 + Compile`$964] - 
       6 (4 (Compile`$955 - a (2 + Compile`$938 - a Compile`$955)) Log[
            a] + a Log[Compile`$954])]]

```

It is a mathematica coding expression, which actually is being processed when I want to extract the replacement rules, changing its own content when I do..
**How could I convert this output to a list of replacement rules**, like 

```
{Compile`$938 -> a^2, Compile`$948 -> a Compile`$938, ..}) 

```

**other than doing the forth and back string conversion?**

The rest of the function is straightforward and does what I want. It is these first couple of lines which I do not like.

Oh and what it does to the expression I actually wanted to process? It decreases the LeafCount from 114 down to 89:

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

```

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

Doing a `FullSimplify` on it further simplifies the expression to a LeafCount of 72:

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

```

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

And if one repeats the procedure on this last output by 
`FullSimplify[nestComplicatedTerms[%]]` the expression is again reduced to a LeafCount of 61.

```
-3 a + 48 a Log[a] - 
 4 (1 + a^2)^(
  3/2) (-5 + Log[512] - 3 Log[1 + Sqrt[1 + 1/a^2]] + 6 Log[a]) + 
 a^3 (-2 + 24 Log[a]) - 6 a Log[1 + a^2]

```

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

I do not know why this is not directly done the first time, though. Anyhow comparing to the initial expression it is much shorter and has way less repeating terms.