System`MyBeginPackage = BeginPackage; System`MyBegin=Begin; System`MyEnd=End; System`MyEndPackage=EndPackage;


(* 

Author: Rolf Mertig       http://www.mertig.com

Copyright:  GPL   (feel free to use modify, etc.)

Install: call this file   Isolate.m 
         Load it from Mathematica by:
         <<Isolate.m

This is all code for the Isolate function as implemented in FeynCalc.
See  
http://www.feyncalc.org/Isolate 
for examples and documentation.
  
Everything is put in the Global` context. Feel  free to change this
by modifying  MyBeginPackge, MyEnd and  MyEndPackage, which don't
do anything here (but in Feyncalc).

Some auxiliary function first:  FreeQ2, Cases2, NumericalFactor

*)


(* :Title: FreeQ2 *)

(* :Author: Rolf Mertig *)

(* ------------------------------------------------------------------------ *)
(* :History: File created on 4 March '97 at 14:34 *)
(* ------------------------------------------------------------------------ *)

(* :Summary: Extension of FreeQ *)

(* ------------------------------------------------------------------------ *)

MyBeginPackage["FreeQ2`"];

FreeQ2::usage =
"FreeQ2[expr, {form1, form2, ...}] yields True if expr does not
contain any occurence of form1, form2, ... and False otherwise.
FreeQ2[expr, form] is the same as FreeQ[expr, form].";

(* ------------------------------------------------------------------------ *)

MyBegin["`Private`"];
   SetAttributes[FreeQ2, ReadProtected];

FreeQ2[_,{}]          := True;
FreeQ2[x_, y_]        := FreeQ[x, y] /; Head[y] =!= List;
FreeQ2[x_, {y_}]      := FreeQ[x, y];
FreeQ2[x_, {y_, z__}] := If[FreeQ[x, y], FreeQ2[x, {z}], False];
(* this is eventually slower ...
FreeQ2[x_, {y_, z__}] := FreeQ[x, Alternatives@@{y,z}];
*)

MyEnd[]; MyEndPackage[];

(* :Title: Cases2 *)

(* :Author: Rolf Mertig *)

(* ------------------------------------------------------------------------ *)
(* :History: File created on 4 March '97 at 14:34 *)
(* ------------------------------------------------------------------------ *)

(* ------------------------------------------------------------------------ *)

MyBeginPackage["Cases2`"];

Cases2::usage=
"Cases2[expr, f] is equivalent to
Cases[{expr}, HoldPattern[f[___]], Infinity]//Union.
Cases2[expr, f1, f2, ...] or
Cases2[expr, {f1, f2, ...}] is equivalent to
Cases[{expr}, f1[___] | f2[___] ..., Infinity]//Union.";

(* ------------------------------------------------------------------------ *)

MyBegin["`Private`"];
   SetAttributes[Cases2, ReadProtected];

Options[Cases2] = {Heads -> False};

Cases2[expr_, {f___}, opts___Rule] := Cases2 @@ Prepend[{f,opts}, expr];
If[$VersionNumber >2.2,
   Cases2[expr_, f_, opts___Rule] := Union[Cases[{expr}, HoldPattern[f[___]],
                                           Infinity,opts]]
   ,
   Cases2[expr_, f_,opts___Rule] := Union[Cases[{expr}, HoldPattern[f[___]],
                                          Infinity,opts]]
  ];
Cases2[expr_, f___, g_] := Union[Cases[{expr},
                            Alternatives@@(#[___]&/@{f,g}),Infinity]
                   ] /; Head[g] =!= Rule;

Cases2[expr_, f__, Heads->True] := Union[Cases[{expr},
              Alternatives@@(#[___]&/@{f,g}),Infinity,Heads->True]];

Cases2[expr_, f__, Heads->False] := Union[Cases[{expr},
              Alternatives@@(#[___]&/@{f,g}),Infinity,Heads->False]];

MyEnd[]; MyEndPackage[];

(* :Title: NumericalFactor *)

(* :Author: Rolf Mertig *)

(* ------------------------------------------------------------------------ *)
(* :History: File created on 4 March '97 at 14:34 *)
(* ------------------------------------------------------------------------ *)

(* :Summary: NumericalFactor take out a numerical factor *)

(* ------------------------------------------------------------------------ *)

MyBeginPackage["NumericalFactor`"];

NumericalFactor::usage = "NumericalFactor NumericalFactor[expr]
gives the numerical factor of expr.";

(* ------------------------------------------------------------------------ *)

MyBegin["`Private`"];
   SetAttributes[NumericalFactor, ReadProtected];

NumericalFactor[a___ /; Length[{a}] =!=1] :=
soso /; Message[NumericalFactor::argrx, NumericalFactor, Length[{a}], 1];
NumericalFactor[x_]:= If[NumberQ[x], x, If[Head[x] === Times,
                         If[NumberQ[First[x]], First[x], 1], 1]];

MyEnd[]; MyEndPackage[];



(* :Title: Isolate *)

(* :Summary: Isolate introduces abbreviations for common 
             subexpressions *)

MyBeginPackage["Isolate`"];

Isolate::usage=
"Isolate[expr] substitutes abbreviations KK[i] for all 
Plus[...] (sub-sums) in expr. The inserted KK[i] have head HoldForm. 
Isolate[expr, varlist] substitutes 
KK[i] for all subsums in expr which are free of any occurence 
of a member of the list varlist. Instead of KK any other head or
a list of names 
of the abbreviations may be specified
with the option IsolateNames.";

IsolateHead::usage =
"IsolateHead is equivalent to IsolateNames.";

IsolateNames::usage =
"IsolateNames is an option for Isolate and Collect2.
Its default setting is KK. Instead of a symbol the
setting may also be a list with the names of the abbrevations.";

IsolateSplit::usage =
"IsolateSplit is an option for Isolate. Its setting determines the
maximum number of characters of FortranForm[expr] which are
abbreviated by Isolate. If the expression is larger than the
indicated number, it is split into smaller pieces and onto
each subsum Isolate is applied.
With the default setting IsolateSplit -> Infinity no splitting
is done.";

IsolatePrint::usage =
"IsolatePrint is an option of Isolate.
If it is set to OutputForm (or any other *Form) the definitions
of the abbreviations are printed during the operation of Isolate.
The setting IsolatePrint -> False suppresses printing.";

KK::usage =
"KK[i] is the default setting of IsolateNames,
which is the head of abbreviations used by Isolate.
A KK[i] returned by Isolate is given in HoldForm and can be
recovered by ReleaseHold[KK[i]].";


MyBegin["`Isolate`"];

(*
Cases2           = MakeContext["Cases2"];
FreeQ2           = MakeContext["FreeQ2"];
IsolateNames     = MakeContext["IsolateNames"];
IsolateSplit     = MakeContext["IsolateSplit"];
IsolatePrint     = MakeContext["IsolatePrint"];
KK               = MakeContext["KK"];
NumericalFactor  = MakeContext["NumericalFactor"];
*)
  

(* :TitleIsolate *)
Isolate[___Rule] := soso /; Message[Isolate::argt, Isolate, 0, 1, 2];

Isolate[_,_,a___,z_/;Head[z] =!= Rule, ___Rule] := 
soso /; Message[Isolate::argt, Isolate, Length[{a}]+3, 1, 2];

Options[Isolate] = {IsolateNames -> KK, 
                    IsolatePrint -> False,
                    IsolateSplit -> Infinity};

Isolate[y_HoldForm^n_., ___] := y^n;
(*
(* for the moment *)
Isolate[a_, ru___Rule] := Isolate[a, dummdumm, ru];
*)
(* this gives Problems if x has large HoldForm's ...
   Isolate[n_?NumberQ x_, y__]  := n Isolate[x, y];
*) 
Isolate[x_?NumberQ, __]      := x;
Isolate[x_Symbol, __]      := x;
Isolate[x_ /; NumericalFactor[x] =!=1, y__ ] := 
        (NumericalFactor[x] Isolate[x/NumericalFactor[x], y]) /; x=!=0;
Isolate[ex_, r___Rule ]      := Isolate[ex, {}, r];
Isolate[ex_, var_, r___Rule] := Isolate[ex, {var}, r]/;
                                (Head[var] =!= Rule) && Head[var] =!= List;
 
Isolate[ exp_ /; Apply[Or[#===1, #===0]&, {NumericalFactor[exp]}], 
         vars_List, ops___Rule 
       ] := 
 Block[{plush,vlist,res,split,kk, di=1, defhead, abbprint,
        holdformlist = {}, hres, nhres, remche},
       kk = IsolateNames/.{ops}/.Options[Isolate];
       If[Head[kk] === List, kk = Flatten[kk];
          If[Length[Union[kk]] =!= Length[kk], kk = Union[kk]];
         ];
       abbprint = IsolatePrint /. {ops} /. Options[Isolate];
       If[abbprint === True, abbprint = OutputForm];
       split = IsolateSplit/.{ops}/.Options[Isolate];
       vlist = Flatten[{vars}];
 (* This split-off is useful for various reasons ... *) 
       plush[x__] := If[ !FreeQ2[{x}, vlist], Plus[x],
          If[ (checkIsolate[x, split] === True ) && 
              (Length[{x}] > 4) && (split =!= Infinity),
              Isolate[ Drop[Plus[x], Round[Length[Plus[x]]/2]] + 
                Isolate[Take[Plus[x], 
                        Round[Length[Plus[x]]/2]], vars, 
                           IsolatePrint->False, ops],
                                  vars,IsolatePrint->False, ops ], 
              If[Head[kk] === List, 
                If[Union[Head/@kk]==={Plus}, kk = {}];
                   remIsolatesave[Plus[x], kk] /. 
                   remIsolatesave -> remIsolate
                ,
                 remIsolate[Plus[x], kk]
                ]
            ]          ];

(*
           If[vars === {}, res = exp,
*)
              res = exp /. Plus -> plush /. plush -> Plus;
(*
             ];
*)
       If[Head[res] =!= HoldForm && vlist === {}, 
          res = remIsolate[res, kk]];
(* do only sums here ...
*)
If[abbprint =!= False,
   holdformlist = Cases2[res, HoldForm];
   hres = ReleaseHold[res];
   holdformlist = Join[holdformlist, Cases2[hres, HoldForm]];
   While[(nhres = ReleaseHold[hres]) =!= hres,
          hres = nhres;
          holdformlist = Join[holdformlist, Cases2[hres, HoldForm]];
        ];
   holdformlist = Union[holdformlist];
      WriteString["stdout", "\n"];
   For[i = 1, i <= Length[holdformlist], i++, 
      Print["       ", holdformlist[[i]], " = ", 
            abbprint[ReleaseHold[holdformlist[[i]]]]
           ];
      WriteString["stdout", "\n"];
      ];
  ];
                                             res](*endIsolate*);
(* three extra "global" functions *)
checkIsolate[x__, i_] := If[Head[i] === Integer,  (* LGF *)
If[Length[Characters[ToString[FortranForm[Plus[x]]]]]>i,True,False],
If[Head[i] === Complex, If[Length[{x}] > Im[i], True, False, False], 
                     False]];
tokIsolate[y_, ab_, uh_] := ab[ToExpression[ StringJoin@@Drop[  
                               Characters[ToString[y]], 
                               Length[Characters[ToString[uh]]]]]];
remIsolate[x_,{}] := 
 remIsolate[x, If[Head[IsolateNames /. Options[Isolate]]===List,
                     KK, IsolateNames /. Options[Isolate]]
              ];

Clear[remIsolatesave];
remIsolate[x_, {a___Plus, abb_ /; Head[abb] =!= Plus, b___}] := 
Block[{re},
      re = HoldForm @@ {abb};
      Set@@{abb, x};
      Set @@ {remIsolatesave[x, _], re};
   re];

remIsolate[x_, abb_ /; Head[abb] =!= List] := Block[{re, h},(*LGF*)
         If[ Length[(re = Select[DownValues @@ {abb}, (#[[2]]===x) &])] > 0,
             re = re[[1,1]] /. {Literal :> HoldForm, HoldPattern :> 
                                HoldForm}
             ,
               If[ Head[abb]===Symbol, 
                   temp = tokIsolate[ uni[ToString[abb]] /.
                                      uni->Unique,abb, abb],
                   temp = tokIsolate[Unique["dude"], abb, "dude"] 
                 ];
               re = HoldForm @@ {temp};
               Set@@{temp, x} 
           ];          re];
     

MyEnd[]; MyEndPackage[];