(* :Title: 	ManipulatePower // Mathematica 2.0 *)

(* :Author: 	Mark Stankus (mstankus). *)

(* :Context: 	ManipulatePower` *)

(* :Summary:
*)

(* :Alias:
*)

(* :Warnings: 
*)

(* :History:
   :8/16/93: rewrote PowerRuleTuple to
             work with Propogate option.  (yoshinob)
 
*)
BeginPackage["ManipulatePower`",
    "Global`","NonCommutativeMultiply`","NCMtools`","Grabs`",
    "System`","ArrayManager`","Inequalities`","SimplePower`",
    "Coefficients`","Tuples`","Errors`"];

Clear[CollapsePower];

CollapsePower::usage = 
      "CollapsePower[(x^n)**(x^m)] gives x^(m+n).";

Clear[PowerRuleTuple];

PowerRuleTuple::usage = 
    "PowerRuleTuple[RuleTuple[ \n \
        Power[x,m]**Power[y,n]->whatever,aList,anotherList]] \n \
     gives \n \ 
     RuleTuple[ \
     NonCommutativeMultiply[ \n \
                 Power[x,Power1], \n \
                 Power[x,m], \n \
                 Power[y,n], \n \
                 Power[y,Power2] \n \
                                   ] -> \n \
             NonCommutativeMultiply[ \n \
                 Power[x,Power1], \n \
                 whatever, \n \
                 Power[y,Power2] \n \
             ], \n \
         Join[aList,{Power1>=0, Power2>=0}],
         Join[anotherList,{Power1,Power2}]
     ]
     where Power1 and Power2 are \
     generated by Unique[].";

Clear[FixPowerRuleTuple];

FixPowerRuleTuple::usage = 
    "FixPowerRuleTuple[] fixes the following deficiency
     in Mma. Note that x^2/.x^(n_+1)->f[n] gives x^2 because \
     Head[n+1]===Plus and Head[2]=!=Plus. The preferred \
     rule is x^(t_)-> f[t-1]. FixPowerRuleTuple[expr] \
     does this for rules with Power (rather than Power).";

Clear[GrabPowers];

GrabPowers::usage = 
     "GrabPowers is called by FixPowerRuleTuple to \
     obtain the powers of expressions in an expanded format.\
     GrabPowers uses the function GrabVariable.";

Clear[PowerDebug];

PowerDebug::usage =
     "PowerDebug";

Clear[PowerNoDebug];

PowerNoDebug::usage =
     "PowerNoebug";

Begin["`Private`"];

PowerDebug[] := debugPower = True;

PowerDebug[x___] := BadCall["PowerDebug",x];

PowerNoDebug[] := debugPower = False;
 
PowerNoDebug[x___] := BadCall["PowerNoDebug",x];

PowerNoDebug[];

CollapsePower[x_] :=  ExpandNonCommutativeMultiply[x] //. {
                Literal[NonCommutativeMultiply[
                             w___,
                             Power[y_,n_],
                             Power[y_,m_],
                             z___             ]
                       ]:>
                NonCommutativeMultiply[w,Power[y,n+m],z],
                Literal[NonCommutativeMultiply[
                             w___,
                             y_,
                             Power[y_,m_],
                             z___             ]
                       ]:>
                NonCommutativeMultiply[w,Power[y,1+m],z],
                Literal[NonCommutativeMultiply[
                             w___,
                             Power[y_,n_],
                             y_,
                             z___             ]
                       ]:>
                NonCommutativeMultiply[w,Power[y,1+n],z],
                Literal[NonCommutativeMultiply[
                             w___,
                             y_,
                             y_,
                             z___             ]
                       ]:>
                NonCommutativeMultiply[w,Power[y,2],z]
           };

CollapsePower[x___] := BadCall["CollapsePower",x];

PowerRuleTuple[x_List] := Flatten[Map[PowerRuleTuple,x]];

PowerRuleTuple[x_Global`RuleTuple] := 
Module[{triple,triples,result},
     triples = PowerRuleAux[NCMToList[x[[1,1]]],x[[1,2]]];
     Do[ triple = triples[[j]];
         If[Not[Length[triple]===3], Print["triple:",triple];
                                     Abort[];
         ];
         triple[[2]] = Join[triple[[2]],x[[2]]];
         triple[[3]] = Join[triple[[3]],x[[3]]];
         result[j]  = Apply[RuleTuple,triple];
     ,{j,1,Length[triples]}
     ];
     Return[Flatten[Table[result[j],{j,1,Length[triples]}]]];
];

PowerRuleTuple[x___] := BadCall["PowerRuleTuple",x];

PowerRuleAux[aListOfPowers_,y_] :=
     If[Length[aListOfPowers]>1, PowerRuleAux1[aListOfPowers,y]
                               , PowerRuleAux2[aListOfPowers[[1]],y]
     ];

PowerRuleAux[x___] := BadCall["PowerRuleAux",x];

PowerRuleAux1[aListOfPowers_,y_] := 
Module[{var1,var2,power1,power2,left,right,ru1,ru2,triples},
      var1 = TheBase[aListOfPowers[[1]]];
      var2 = TheBase[aListOfPowers[[-1]]];

      power1 = Global`UniqueMonomial["PowerRule"];
      power2 = Global`UniqueMonomial["PowerRule"];

      left = Join[{Power[var1,power1]},
                  aListOfPowers,
                  {Power[var2,power2]}
                 ];
      left = Apply[NonCommutativeMultiply,left];

      right = Power[var1,power1]**y**Power[var2,power2];
      right = ExpandNonCommutativeMultiply[right];
      ru1 = power1->1 - ThePower[aListOfPowers[[1]]];
      ru2 = power2->1 - ThePower[aListOfPowers[[-1]]];
      triples = {
         {left->right,
          {power1>=0,power2>=0},
          {power1,power2}},
         {((left->right)/.ru1),
          ({power1>=0,power2>=0}/.ru1),
          {power2}},
         {((left->right)/.ru2),
          ({power1>=0,power2>=0}/.ru2),
          {power1}},
         {((left->right)/.ru1/.ru2),
          ({power1>=0,power2>=0}/.ru1/.ru2),
          {}}
                 };
      triples = {triples[[1]]};
      Return[triples];
];

PowerRuleAux1[x___] := BadCall["PowerRuleAux1",x];

PowerRuleAux2[aPower_,y_] := 
Module[{var,power,left,right,triples,ru},
      var = TheBase[aPower];

      power = Global`UniqueMonomial["PowerRule"];

      left = Power[var,power]**aPower;

      right = Power[var,power]**y;
      right = ExpandNonCommutativeMultiply[right];
      ru = power->1 - ThePower[aPower];
      triples =  {
             {left->right,
              {power>=0},
              {power}},
             {((left->right)/.ru),
              ({power>=0}/.ru),
              {}}
                 };
      triples = {triples[[1]]};
      ru = power->1 - ThePower[aPower];
      Return[triples];
];

PowerRuleAux2[x___] := BadCall["PowerRuleAux2",x];

PowerRule[x_Rule] := {x,{},{}};

PowerRule[x___] := BadCall["PowerRule",x];

FixPowerRuleTuple[x_List] := Map[FixPowerRuleTuple,x];

FixPowerRuleTuple[Global`RuleTuple[Rule[x_,y_],ineqList_List,varList_List]] := 
Module[{FreeVarList,IneqList,LHS,RHS,aListOfPowersLHS,aListOfPowersRHS,
        NumberOfPowersLHS,NumberOfSymbols,aListOfRelations,aListOfSymbols,
        NewRules,j,result},
If[debugPower, Print["Input to FixPowerRuleTuple"];
               Print[Format[Global`RuleTuple[Rule[x,y],ineqList,varList],
                            InputForm]];
];
   FreeVarList = varList ;
   IneqList = ineqList;
   LHS = x;
   RHS = y;
   aListOfPowersLHS = Flatten[{GrabPowers[x]}];
   aListOfPowersRHS = Flatten[{GrabPowers[y]}];
   aListOfPowersLHS = Union[aListOfPowersLHS,aListOfPowersLHS];
   NumberOfPowersLHS = Length[aListOfPowersLHS];
   aListOfSymbols = Select[aListOfPowersLHS,Not[Head[#]===Integer]&];
   NumberOfSymbols = Length[aListOfSymbols];
   aListOfRelations = Table[aListOfSymbols[[j]] == internal$$[j]
                            ,{j,1,NumberOfSymbols}];    
   NewRules = Flatten[Solve[aListOfRelations,FreeVarList]];
   If[NewRules === {}
        , result = RuleTuple[x->y,IneqList,FreeVarList]; 
        , LHS = LHS/.NewRules;
          RHS = RHS/.NewRules;
          FreeVarList = Table[internal$$[j],{j,1,NumberOfSymbols}];
          IneqList = IneqList/.NewRules;
          NewRuleTuple = RuleTuple[LHS->RHS,IneqList,FreeVarList];
          NewRuleTuple = SmartTupleUnion[NewRuleTuple];
          result = CleanUpTuple[NewRuleTuple];
   ];
If[debugPower, Print["Output from FixPowerRuleTuple"];
               Print[Format[result,InputForm]];
];
   Return[result];
];

FixPowerRuleTuple[x___] := BadCall["FixPowerRuleTuple",x];

GrabPowers[x_Plus] := Flatten[Map[GrabPowers,Apply[List,x]]];

GrabPowers[x_Times] := Flatten[Map[GrabPowers,Apply[List,x]]];

GrabPowers[c_?NumberQ] := {};

GrabPowers[c_Coeff] := {};

GrabPowers[x_Power] := Grabs`GrabVariable[ThePower[x]];

GrabPowers[x_NonCommutativeMultiply] :=
Module[{ListForm,result},
   ListForm = Apply[List,x];
   result = Map[GrabPowers,ListForm];
   result = Flatten[result];
   Return[result];
];

GrabPowers[x_] := {};

GrabPowers[x___] := BadCall["GrabPowers",x];

End[];
EndPackage[]
