(*********************************************************************** This file was generated automatically by the Mathematica front end. It contains Initialization cells from a Notebook file, which typically will have the same name as this file except ending in ".nb" instead of ".m". This file is intended to be loaded into the Mathematica kernel using the package loading commands Get or Needs. Doing so is equivalent to using the Evaluate Initialiation Cells menu command in the front end. DO NOT EDIT THIS FILE. This entire file is regenerated automatically each time the parent Notebook file is saved in the Mathematica front end. Any changes you make to this file will be overwritten. ***********************************************************************) Off[General::"spell",General::"spell1",Remove::"rmnsm",UpSet::"write"]; Unprotect["Global`*"];ClearAll["Global`*"];Remove["Global`*"];Unprotect[$]; ClearAll[Wedge,K,$];Protect[$];Unprotect[In,Out];Clear[In,Out]; Protect[In,Out];$Line=0;$RecursionLimit=256;$IterationLimit=4096; Forms[i_]:={};AllScalForms={};matForms[i_]:={};AllMatForms={};AllDifForms={}; AllMatrices={};AllSymbols={};FormVars={_Wedge,_d};ZeroVars={_Wedge,_tr}; HeadList={};ScalHeadList={};MatFormHeadList={};ZeroHeads={};AllMatHeads={}; nodHeads={tr,Bar,Pattern,Condition,RuleDelayed,SeriesData};$EDCversion=370; zeroQ[0]=True;zeroQ[x_List]:=And@@(zeroQ/@Union[Flatten[x]]); zeroQ[x_SeriesData]:=If[x[[3]]==={},True,False];zeroQ[x_]:=False; SetAttributes[Bar,{Listable}];Bar[Bar[x_]]=x; Bar[Complex[x_,y_]]:=Complex[x,-y]; Bar[x_Plus|x_Times|x_Wedge|x_Power|x_Rule|x_Equal]:=Bar/@x; Bar[x_?NumericQ]:=x; Bar[x_RuleDelayed]:=Rule[Bar[x[[1]]],Bar[x[[2]]]]/.Rule\[Rule]RuleDelayed; Bar[x_SeriesData]:= x/.{First[x]->Bar[First[x]],x[[2]]->Bar[x[[2]]],x[[3]]->Bar/@x[[3]]}; Bar[DirectedInfinity[x_]]:=DirectedInfinity[Bar[x]]; Bar[HoldPattern[tr[x_]]]:=tr[Bar[x]];Bar[d[x_]]:=d[Bar[x]]; Bar[x_Condition]:=Condition[Bar[x[[1]]],x[[2]]]; Bar[Derivative[x__][y_][z__]]:= If[Union[Bar[{z}]]===Union[{z}], Derivative[Sequence@@Coefficient[{x}.{z},Bar[{z}]]][Bar[y]][z], Derivative[x][Bar[y]][Sequence@@Bar[{z}]]]; Bar[h_[y__]/;FreeQ[nodHeads,h]]:= If[Union[Bar[{y}]]===Union[{y}],Bar[h][y],Bar[h][Sequence@@Bar[{y}]]]/; FreeQ[{Integer,Blank,Pattern,Condition},Head[First[{y}]]]; Qvalue[x_List]:= Length[Select[OrderedQ/@Transpose[{Drop[x,-1],Rest[x]}],#===False&]] AllCaseTable[x_List]:= With[{rvstr=Reverse[Map[Transpose,x]/.-z_\[Rule]z]}, If[traceOption===2, Join[Table[{Qvalue[RotateLeft[x,i]],RotateLeft[x,i],i},{i,0, Length[x]-1}], Table[{Qvalue[RotateRight[rvstr,i]],RotateRight[rvstr,i],-i-1},{i,0, Length[x]-1}]], Table[{Qvalue[RotateLeft[x,i]],RotateLeft[x,i],i},{i,0,Length[x]-1}]]] bestOrd[x_List]:= Block[{tmp=Sort[AllCaseTable[x]]},tmp=Select[tmp,First[#1]===tmp[[1,1]]&]; If[Length[tmp]>1, First[Sort[Select[tmp,#1[[2]]===tmp[[1,2]]&], Abs[Last[#1]]tr/@x[[3]])+(x/.x[[3]]\[Rule]{}); tr[x__ y_]:=(x tr[y])/;!MatQ[x];tr[d[x_]]:=d[tr[x]]; tr[x__\[Wedge]y__]:=(x\[Wedge]tr[Wedge[y]])/;ScalFormQ[x]; tr[x_]:=(tr[x]=0)/;AntisymQ[x]; tr[Bar[x_]]:=With[{evalHx=tr[x]},Bar[evalHx]/;Head[evalHx]=!=tr]; tr[x_Wedge/;Union[Head/@Level[x,1]]==={Bar}]:= With[{evalHx=tr[Bar/@x]},Bar[evalHx]/;Head[evalHx]=!=tr]; tr[x_Wedge]:= Block[{inpList=List@@x,resList,FDx},resList=bestOrd[inpList]; FDx=FormDegree/@inpList; Which[ Last[resList]> 0,(-1)^splitFDprod[ Last[resList],FDx]tr[Wedge@@resList[[2]]], Last[resList]===-1,(-1)^( allFDprods[FDx]+Length[Select[inpList,AntisymQ]])tr[ Wedge@@resList[[2]]], Last[resList]<-1,(-1)^( allFDprods[FDx]+splitFDprod[Abs[1+ Last[resList]],FDx]+ Length[Select[inpList,AntisymQ]])tr[Wedge@@resList[[2]]]]]/; traceOption>0&&bestOrd[List@@x][[2]]=!=List@@x; tr[x__\[Wedge]y__]:=(tr[x\[Wedge]y]=0)/;( SymQ[Wedge[x]]&&AntisymQ[Wedge[y]]||SymQ[Wedge[y]]&&AntisymQ[Wedge[x]]); tr[x_]:=x matDimension/;!MatQ[x]; toComponents[x_+y_,rul_]:=toComponents[x,rul]+toComponents[y,rul]; toComponents[x_.*y_,rul_]:= If[MatQ[x*y],reWrite[x*y/.rul], reWrite[(x*y* IdentityMatrix[ Length[Select[Part[#,2]&/@rul,MatrixQ][[1]]]])/.rul]]; toComponents[x_\[Wedge]y_,rul_]:= If[MatQ[x\[Wedge]y],reWrite[x\[Wedge]y/.rul], reWrite[(x\[Wedge]y* IdentityMatrix[ Length[Select[Part[#,2]&/@rul,MatrixQ][[1]]]])/.rul]]; FormDegree[x_Plus]:=FormDegree[First[x]]; FormDegree[x_Times]:=Plus@@FormDegree/@List@@x; FormDegree[x_Wedge]:=Plus@@FormDegree/@List@@x; FormDegree[d[x_]]:=FormDegree[d[x]]=1+FormDegree[x]; FormDegree[x_List]:=FormDegree[Last[Union[Flatten[x]]]]; FormDegree[tr[x_]]:=FormDegree[x]; FormDegree[Bar[x_]]:=FormDegree[Bar[x]]=FormDegree[x]; FormDegree[x_SeriesData]:=If[x[[3]]==={},0,FormDegree[x[[3]]]]; FormDegree[x_]:=0; DeclareMatrixForms[z__]:= Block[{x={{z}},xi,rxi,h,ht,k,min1,oldHeads,newHeads}, While[Head[x[[1,1]]]===List,x=First[x]];Unprotect[Transpose]; Do[xi=x[[i]]; If[xi[[3]]===xi[[2]]||xi[[3]]===-xi[[2]],rxi={xi[[2]]},rxi=Rest[xi]]; matForms[First[xi]]=Union[matForms[First[xi]],rxi]; \[IndentingNewLine]AllMatrices=Union[AllMatrices,rxi];h=Head[xi[[2]]]; If[First[xi]>0,AllMatForms=Union[AllMatForms,rxi], If[h=!=Symbol,ZeroHeads=Union[{h},ZeroHeads]; If[Head[xi[[3]]]=!=Times, ZeroHeads=Union[{Head[xi[[3]]]},ZeroHeads]]]]; If[h===Symbol,FormDegree[xi[[2]]]=First[xi];BasicMatQ[xi[[2]]]=True; BasicScalFormQ[xi[[2]]]=False;Transpose[xi[[2]]]=xi[[3]]; If[xi[[3]]===-xi[[2]],tr[xi[[2]]]=0, If[xi[[3]]=!=xi[[2]],FormDegree[xi[[3]]]=First[xi]; BasicMatQ[xi[[3]]]=True;BasicScalFormQ[xi[[3]]]=False; Transpose[xi[[3]]]=xi[[2]];tr[xi[[3]]]=tr[xi[[2]]]]], FormDegree[_h]=First[xi];BasicMatQ[_h]=True;BasicScalFormQ[_h]=False; ht=Head[xi[[3]]]; If[ht===Times,min1=-1;ht=h;tr[h[k_]]=0,min1=1; If[ht=!=h,FormDegree[_ht]=First[xi];BasicMatQ[_ht]=True; BasicScalFormQ[_ht]=False;tr[ht[k_]]=tr[h[k]]]]; Transpose[h[k_]]=min1 ht[k];Transpose[ht[k_]]=min1 h[k]],{i, Length[x]}];Protect[Transpose]; \[IndentingNewLine]AllDifForms=Union[AllScalForms,AllMatForms]; AllSymbols=Union[AllDifForms,AllMatrices]; MatFormHeadList= Complement[Union[Head/@AllMatForms,MatFormHeadList],{Symbol}]; oldHeads=AllMatHeads;AllMatHeads=Union[ZeroHeads,MatFormHeadList]; newHeads=Complement[AllMatHeads,oldHeads]; \[IndentingNewLine]HeadList=Union[Head/@AllSymbols]; DifFormSymbols= Drop[AllDifForms,-Length[Union[ScalHeadList,MatFormHeadList]]]; nodHeads=Union[nodHeads,ZeroHeads]; k=Thread[Blank[Union[ScalHeadList,MatFormHeadList]]]; FormVars=Flatten[{_Wedge,_d,Union[k,Bar[k]], y_|Bar[y_]/;MemberQ[DifFormSymbols,y],_tr}]; ZeroMatSymbols=Drop[matForms[0],-Length[ZeroHeads]]; ZeroVars=Flatten[{_Wedge, Union[Thread[Blank[ZeroHeads]],Bar[Thread[Blank[ZeroHeads]]]], y_|Bar[y_]/;MemberQ[ZeroMatSymbols,y],_tr}];]; DeclareForms[z__]:= Block[{h,x={{z}},xi,rxi,k,oldHeads,newHeads}, While[Head[x[[1,1]]]===List,x=First[x]]; Do[xi=x[[i]];rxi=Rest[xi];Forms[First[xi]]=Union[Forms[First[xi]],rxi]; \[IndentingNewLine]AllScalForms=Union[AllScalForms,rxi]; \[IndentingNewLine]Do[h=Head[rxi[[j]]]; If[h===Symbol,FormDegree[rxi[[j]]]=First[xi]; BasicScalFormQ[rxi[[j]]]=True;BasicMatQ[rxi[[j]]]=False;, FormDegree[_h]=First[xi];BasicScalFormQ[_h]=True; BasicMatQ[_h]=False;],{j,Length[rxi]}],{i,Length[x]}]; \[IndentingNewLine]AllDifForms=Union[AllScalForms,AllMatForms]; oldHeads=ScalHeadList; ScalHeadList=Complement[Union[Head/@AllScalForms,ScalHeadList],{Symbol}]; newHeads=Complement[ScalHeadList,oldHeads]; AllSymbols=Union[AllDifForms,AllMatrices]; \[IndentingNewLine]HeadList=Union[Head/@AllSymbols]; DifFormSymbols= Drop[AllDifForms,-Length[Union[ScalHeadList,MatFormHeadList]]]; k=Thread[Blank[Union[ScalHeadList,MatFormHeadList]]]; FormVars=Flatten[{_Wedge,_d,Union[k,Bar[k]], y_|Bar[y_]/;MemberQ[DifFormSymbols,y],_tr}];]; NoDif[z__]:=(nodHeads=Union[nodHeads,Flatten[{z}]];) BasicMatQ[Bar[x_]]:=BasicMatQ[x];BasicMatQ[d[x_]]:=BasicMatQ[x]; BasicMatQ[x_List]=True;BasicMatQ[x_]:=False; MatQ[x_Times|x_Wedge|x_Plus]:=Or@@MatQ/@List@@x; MatQ[x_SeriesData]:=Or@@MatQ/@x[[3]];MatQ[x_]:=BasicMatQ[x]; BasicScalFormQ[HoldPattern[tr[x_]]]:=FormDegree[x]>0; BasicScalFormQ[Bar[x_]]:=BasicScalFormQ[x]; BasicScalFormQ[d[x_]]:=!BasicMatQ[x];BasicScalFormQ[x_]:=False; ScalFormQ[x_Times]:=Or@@ScalFormQ/@List@@x; ScalFormQ[x_Wedge|x_Plus]:=And@@ScalFormQ/@List@@x; ScalFormQ[x_]:=BasicScalFormQ[x]; Unprotect[Transpose];Transpose[x_Plus]:=Transpose/@x; Transpose[x_SeriesData]:=x/.x[[3]]->Transpose/@x[[3]]; Transpose[x__ y_]:=x Transpose[y]/;!MatQ[x]; Transpose[x__\[Wedge]y__]:=(x\[Wedge]Transpose[Wedge[y]])/;ScalFormQ[x]; Transpose[ x_Wedge]:=(-1)^allFDprods[FormDegree/@(List@@x)]Wedge@@ Map[Transpose,Reverse[List@@x]];Transpose[d[x_]]:=d[Transpose[x]]; HoldPattern[Transpose[Bar[x_]]]:=Bar[Transpose[x]];Transpose[x_]:=x/;!MatQ[x]; Protect[Transpose]; SymQ[Bar[x_]]:=Union[Flatten[{reWrite[Transpose[x]-x]}]]==={0}; AntisymQ[Bar[x_]]:=Union[Flatten[{reWrite[Transpose[x]+x]}]]==={0}; SymQ[x_]:=Union[Flatten[{reWrite[Transpose[x]-x]}]]==={0}; AntisymQ[x_]:=Union[Flatten[{reWrite[Transpose[x]+x]}]]==={0}; SetAttributes[d,{Listable}]; d[x_Times|x_Wedge]:= d[First[x]]\[Wedge]Rest[x]+(-1)^FormDegree[First[x]]* First[x]\[Wedge]d[Rest[x]];d[x_?NumericQ|x_d]=0;d[matDimension]=0; d[Power[y_,n_]]:=n y^(n-1) d[y]+y^n Log[y]d[n];d[x_Plus]:=d/@x; HoldPattern[d[tr[x_]]]:=With[{evalHx=d[x]},tr[evalHx]/;Head[evalHx]=!=d]; HoldPattern[d[Bar[x_]]]:=With[{evalHx=d[x]},Bar[evalHx]/;Head[evalHx]=!=d]; d[x_Rule|x_Equal]:=reWrite[d/@x]; d[x_SeriesData]:=(x/.x[[3]]->d[x[[3]]])+Wedge[d[First[x]],D[x,First[x]]]; d[h_[y__]/;FreeQ[nodHeads,h]]:= Sum[(Derivative[ Sequence@@RotateRight[Append[Table[0,{Length[{y}]-1}],1],i]][ h][y])d[{y}[[i]]],{i,Length[{y}]}]/; FormDegree[h[y]]===0&& FreeQ[{Integer,Blank,Pattern,Condition},Head[First[{y}]]]; newSer$[x_SeriesData,k_]:= SeriesData[First[x],x[[2]], Flatten[Transpose[ Prepend[Table[Table[0,{Length[x[[3]]]}],{k-1}],x[[3]]]]],k x[[4]], k x[[5]],k Last[x]] Wedge[x_]:=x/;Length[{x}]<2&&Head[{x}[[1]]]=!=Pattern Default[Wedge]:=1;SetAttributes[Wedge,{Flat,OneIdentity}];Wedge[0,y__]=0; Wedge[x__,0]=0; Wedge[x_SeriesData,y_SeriesData]:= Block[{x$,y$,r1,r2,res,x3,y3}, If[Last[x]===Last[y],x$=x;y$=y, x$=newSer$[x,LCM[Last[x],Last[y]]/Last[x]]; y$=newSer$[y,LCM[Last[x],Last[y]]/Last[y]]];r1=x$[[-3]]+y$[[-3]]; r2=Min[x$[[-2]]+y$[[-3]],x$[[-3]]+y$[[-2]]]; If[Length[x$[[3]]]Map[Wedge[y,#]&,x[[3]]]; Wedge[x_SeriesData,y_]:=x/.x[[3]]->Map[Wedge[#,y]&,x[[3]]]; Wedge[x__,y_Plus]:=Plus@@Map[Wedge[x,#]&,List@@y]; Wedge[x_Plus,y__]:=Plus@@Map[Wedge[#,y]&,List@@x]; Wedge[z__,Times[x_,y_]]:= Times[x,Wedge[z,y]]/;NumericQ[x]||(FormDegree[x]===0&&!MatQ[x]); Wedge[Times[x_,y_],z__]:= Times[x,Wedge[y,z]]/;NumericQ[x]||(FormDegree[x]===0&&!MatQ[x]); Wedge[x_^n_.,y_]:=x^n*y/;FormDegree[x]===0&&!MatQ[x]; Wedge[y_,x_^n_.]:=x^n*y/;FormDegree[x]===0&&!MatQ[x]; Wedge[x_,y___,x_]:=0/;OddQ[FormDegree[x]]&&ScalFormQ[x]; Wedge[x__,y__]:=(-1)^(FormDegree[x]*FormDegree[y])*y\[Wedge]x/; MatQ[x]&&ScalFormQ[y]; Wedge[x__]:= Block[{doubL=Transpose[{FormDegree/@{x},{x}}]}, Signature[Select[doubL,OddQ[First[#]]&]]Wedge@@ Map[Last[#1]&,Sort[doubL]]]/; Union[BasicScalFormQ/@{x}]==={True}&& Map[Last[#1]&,Sort[Transpose[{FormDegree/@{x},{x}}]]]=!={x}; Wedge[x_List,y_List]:= If[(FormDegree[x]===0&&!MatQ[Last[Union[Flatten[x]]]])||( FormDegree[y]===0&&!MatQ[Last[Union[Flatten[y]]]]),Dot[x,y], Inner[Wedge,x,y]]; Wedge[x_,y_List]:= If[FormDegree[x]===0||(FormDegree[y]===0&&!MatQ[Last[Union[Flatten[y]]]]), x *y,Map[Wedge[x,#]&,y]]/;!BasicMatQ[x]; Wedge[x_List,y_]:= If[FormDegree[y]===0||(FormDegree[x]===0&&!MatQ[Last[Union[Flatten[x]]]]), x*y,Map[Wedge[#,y]&,x]]/;!BasicMatQ[y]; simpRules = {Cos[z_]^2*(x_.)+(x_.)*Sin[z_]^2 -> x};varList={}; coll[x_]:=Collect[x,{_Wedge,_tr},Factor]/.simpRules; SetAttributes[reWrite,{Listable}];reWrite[0]=0; reWrite[x_Equal]:=Equal[reWrite[First[x]-Last[x]],0]; reWrite[x_Rule]:=Rule[First[x],reWrite[Last[x]]]; reWrite[x_RuleDelayed]:=Rule[First[x],reWrite[x[[2]]]]/.Rule->RuleDelayed; reWrite[x_SeriesData]:=(x/.x[[3]]->reWrite[x[[3]]]); reWrite[x_Condition]:=Condition[reWrite[x[[1]]],x[[2]]]; reWrite[x_]:=(Collect[coll[x/.simpRules],FormVars,bestFacRul]/.simpRules)/; FormDegree[x]>0; reWrite[x_]:=(Collect[x/.simpRules,ZeroVars,bestFacRul]/.simpRules)/;MatQ[x]; reWrite[x_]:=bestFacRul[x/.simpRules]/.simpRules; FreeALLQ[x_,y_List]:=And@@(FreeQ[x,#]&/@y); bestFacRul[x_]:= If[varList==={}||FreeALLQ[x,varList],minFacRul[x],varFacRul[x]]; varFacRul[x_]:=Collect[Expand[x]/.simpRules,varList,Factor]/.simpRules; minFacRul[x_]:=Factor[Expand[x]/.simpRules]/.simpRules; Unprotect[SeriesData];If[$VersionNumber<5,Times[x_SeriesData,0]^=0]; SeriesData[x1_,x2_,x3_,x4_,x5_,x6_]:= Plus@@If[x2===Infinity, Map[First[#]/x1^((x4+Last[#]-1)/x6)&, Transpose[{x3,Range[Length[x3]]}]]+SeriesData[x1,x2,{},x4,x5,x6], Map[First[#]*(x1-x2)^((x4+Last[#]-1)/x6)&, Transpose[{x3,Range[Length[x3]]}]]+ SeriesData[x1,x2,{},x4,x5,x6]]/;!FreeQ[x3,x1];Protect[SeriesData]; CHcoef[x_,0]=1;CHcoef[x_,1]:=tr[x]; CHcoef[x_,n_]:=CHcoef[x,n]=reWrite[tr[CHeq[x,n]]/n]; CHeq[x_,n_]:= reWrite[CHcoef[x,n-1]\[Wedge] x+ Sum[(-1)^(i-1)CHcoef[x,n-i]\[Wedge]Wedge@@Table[x,{i}],{i,2,n}]]; subMatDR[m_,p_,q_]:=Transpose[Drop[Transpose[Drop[m,p]],q]]; subMatTK[m_,p_,q_]:=Transpose[Take[Transpose[Take[m,p]],q]]; DeclareMatrixForms[{0,$,$t}] CHrul[n_,x_:$]:= Block[{cn=CHeq[x,n],cn0,rul,tmp,r1,r2}, If[FormDegree[x]>0,Print[x," is not a 0-form matrix"];Return[]]; matDimension=n; rul=First[Solve[cn==cn0,Wedge@@Table[x,{n}]]]/.cn0->tr[cn]/n; rul=reWrite[rul]; If[x===$,tmp=MapAt[HoldPattern,rul/.Rule->RuleDelayed,{1,1}]; r1=tmp[[1,1]];r2=r1/.$->Pattern[$,Blank[]]; tmp={Rule[r2, tmp[[1,2]]/; MatQ[$]&&FormDegree[$]===0&&matDimension===n]}/.Rule-> RuleDelayed,tmp=rul]]; On[General::"spell",General::"spell1",UpSet::"write"];