(* ::Package:: *)

(************************************************************************)\012(* This file was generated automatically by the Mathematica front end.  *)\012(* It contains Initialization cells from a Notebook file, which         *)\012(* typically will have the same name as this file except ending in      *)\012(* ".nb" instead of ".m".                                               *)\012(*                                                                      *)\012(* This file is intended to be loaded into the Mathematica kernel using *)\012(* the package loading commands Get or Needs.  Doing so is equivalent   *)\012(* to using the Evaluate Initialization Cells menu command in the front *)\012(* end.                                                                 *)\012(*                                                                      *)\012(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)\012(* automatically each time the parent Notebook file is saved in the     *)\012(* Mathematica front end.  Any changes you make to this file will be    *)\012(* overwritten.                                                         *)\012(************************************************************************)\012\012

(* ::Input::Initialization:: *)
SetDirectory["C:/drorbn/AcademicPensieve/Projects/glneps"];


(* ::Input::Initialization:: *)
VarPattern=((y|x|\[Eta]|\[Xi])|Subscript[(y|x|\[Eta]|\[Xi]), __])[_];


(* ::Input::Initialization:: *)
{SuperStar[y],SuperStar[x],SuperStar[\[Eta]],SuperStar[\[Xi]]}={\[Eta],\[Xi],y,x}; 
SuperStar[(Subscript[u_, \[Alpha]\[Beta]__])]:=Subscript[(SuperStar[u]), \[Alpha]\[Beta]];
SuperStar[((u:((y|x|\[Eta]|\[Xi])|Subscript[(y|x|\[Eta]|\[Xi]), __]))[i_])]:=SuperStar[u][i];
SuperStar[(vs_List)]:=(v|->SuperStar[v])/@vs;


(* ::Input::Initialization:: *)
{
 {Wt[Subscript[x, \[Alpha]_,\[Beta]_]]:={1,\[Alpha]-\[Beta]};, Wt[Subscript[y, \[Alpha]_,\[Beta]_]]:={0,\[Alpha]-\[Beta]};},
 {Wt[Subscript[\[Xi], \[Alpha]_,\[Beta]_]]:={0,\[Beta]-\[Alpha]};, Wt[Subscript[\[Eta], \[Alpha]_,\[Beta]_]]:={1,\[Beta]-\[Alpha]};}
};
Wt[u_[_]] := Wt[u];


(* ::Input::Initialization:: *)
$k=2;


(* ::Input::Initialization:: *)
LogReduce[\[ScriptCapitalE]_]:=\[ScriptCapitalE]/.c_*Log[a_]:>Log@Factor[a^c]//.Log[a_]+Log[b_]:>Log@Factor[a b];
CF[\[ScriptCapitalE]_] := Expand@Collect[\[ScriptCapitalE],Cases[\[ScriptCapitalE],VarPattern,\[Infinity]],CCF]/.CCF->Factor;
CF[\[ScriptCapitalE]_\[DoubleStruckCapitalE]]:=CF/@MapAt[LogReduce,\[ScriptCapitalE],1];
CF[\[ScriptCapitalE]:Subscript[\[DoubleStruckCapitalE], __][___]]:=CF/@\[ScriptCapitalE];


(* ::Input::Initialization:: *)
\[ScriptCapitalE]_\[DoubleStruckCapitalE][$]:=Length[\[ScriptCapitalE]]-1; Subscript[\[DoubleStruckCapitalE], _][\[ScriptCapitalE]s___][$]:=\[DoubleStruckCapitalE][\[ScriptCapitalE]s][$];\[ScriptCapitalE]_\[DoubleStruckCapitalE][k_Integer]:=\[ScriptCapitalE][[k+1]]; Subscript[\[DoubleStruckCapitalE], _][\[ScriptCapitalE]s___][k_Integer]:={\[ScriptCapitalE]s}[[k+1]];
\[DoubleStruckCapitalE]/:\[ScriptCapitalE]1_\[DoubleStruckCapitalE]\[Congruent]\[ScriptCapitalE]2_\[DoubleStruckCapitalE]:=Inner[CF@#1==CF@#2&, \[ScriptCapitalE]1,\[ScriptCapitalE]2,And];
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]\[Congruent]Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] ^:= (d1==d2)\[And](r1==r2)\[And](\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]\[Congruent]\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]);
\[DoubleStruckCapitalE]/:\[ScriptCapitalE]1_\[DoubleStruckCapitalE]*\[ScriptCapitalE]2_\[DoubleStruckCapitalE]:=\[DoubleStruckCapitalE]@@Table[CF[\[ScriptCapitalE]1[kk]+\[ScriptCapitalE]2[kk]],{kk,0,Min[\[ScriptCapitalE]1[$],\[ScriptCapitalE]2[$]]}];
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] ^:= Subscript[\[DoubleStruckCapitalE], (d1\[Union]d2)->(r1\[Union]r2)]@@(\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]);


(* ::Input::Initialization:: *)
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]//Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] :=Module[{is=r1\[Intersection]d2,lvs,llvs},
lvs=Cases[{\[ScriptCapitalE]1s},Subscript[(x|y), __][i_]/;MemberQ[is,i],\[Infinity]]\[Union]SuperStar[Cases[{\[ScriptCapitalE]2s},Subscript[(\[Xi]|\[Eta]), __][i_]/;MemberQ[is,i],\[Infinity]]];
llvs=Map[$,lvs,{2}];
Subscript[\[DoubleStruckCapitalE], (d1\[Union]Complement[d2,is])->(r2\[Union]Complement[r1,is])]@@(Subscript[Zip, llvs\[Union]SuperStar[llvs]][{SuperStar[(llvs)] . (llvs),Times[
\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]/.Thread[lvs->llvs],
\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]/.Thread[SuperStar[lvs]->SuperStar[llvs]]
]}])
]


(* ::Input::Initialization:: *)
Subscript[Zip, vs_][{\[ScriptCapitalF]_,\[ScriptCapitalE]_}]:=Module[{dvs=Select[vs,(Wt[#]=={0,0}\[Or]Wt[#]=={1,0})&]},
{\[ScriptCapitalF],\[ScriptCapitalE]}//Subscript[Zip1, vs](*//Subscript[Zip2, Complement[vs,dvs]]*)//Subscript[Zip2, dvs]//Subscript[Zip3, Complement[vs,dvs]]//Subscript[Zip3, dvs]
]//Last


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Zip1\), \({}\)]\)=Identity;
Subscript[Zip1, vs_]@{\[ScriptCapitalF]_,\[DoubleStruckCapitalE][Q_,P___]} := Module[{\[ScriptCapitalI],F,G,u,v},
\[ScriptCapitalI]=IdentityMatrix@Length@vs;
F=Table[If[Wt[u]+Wt[v]=={1,0},\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\[ScriptCapitalF]\),0],{u,vs},{v,vs}];
G=Table[If[Wt[u]+Wt[v]=={1,0},\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]Q\),0],{u,vs},{v,vs}];
{CF[(vs) . (F . Inverse[\[ScriptCapitalI]-G . F]) . (vs)/2], \[DoubleStruckCapitalE][CF[Q-PowerExpand@Log[Det[\[ScriptCapitalI]- G . F]]/2-vs . G . vs/2],P]}
]


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Zip2\), \({}\)]\)=Identity;
Subscript[Zip2, vs_]@{\[ScriptCapitalF]_,\[DoubleStruckCapitalE][Q_,P___]} := Module[{F,Y,u,v},
F=Table[If[Wt[u]+Wt[v]=={1,0},CF[\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\[ScriptCapitalF]\)],0],{u,vs},{v,vs}];
Y=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]Q\),{v,vs}]/.Table[v->0,{v,vs}];
CF/@{\[ScriptCapitalF], \[DoubleStruckCapitalE][Q-Y . vs+Y . F . Y/2, P]/.Thread[vs->vs+F . Y]}
]


(* ::Input::Initialization:: *)
Subscript[Zip3, vs_]@{\[ScriptCapitalF]_,\[ScriptCapitalE]_\[DoubleStruckCapitalE]} := Module[{F,u,v,Z,kk,jj,$m=0,m,n},
Do[Z[0,kk]=\[ScriptCapitalE][[kk+1]],{kk,0,\[ScriptCapitalE]@$}];
F[u_,v_]:=F[u,v]=CF@If[Wt[u]+Wt[v]=={1,0},\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\[ScriptCapitalF]\),0];
Z[m_,kk_,u_]:=Z[m,kk,u]=\!\(
\*SubscriptBox[\(\[PartialD]\), \(u\)]\(Z[m, kk]\)\);
Z[m_,kk_,u_,v_]:=Z[m,kk,u,v]=\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]\(Z[m, kk, u]\)\);
For[m=0,m<=2$m,++m,For[kk=0,kk<=\[ScriptCapitalE]@$,++kk,
Z[m+1,kk]=CF@Sum[
If[F[u,v]===0,0,F[u,v]/(2(m+1)) (Z[m,kk,u,v]+Sum[Z[n,jj,u]*Z[m-n,kk-jj,v],{n,0,m},{jj,0,kk}])],
{u,vs},{v,vs}];
If[Z[m+1,kk]=!=0, $m=m+1]
]];
CF/@({
\[ScriptCapitalF]-Sum[F[u,v]*u*v/2,{u,vs},{v,vs}],
\[DoubleStruckCapitalE]@@Table[Sum[Z[m,kk],{m,0,$m}],{kk,0,\[ScriptCapitalE]@$}]
}/.Table[v->0,{v,vs}])
]


(* ::Input::Initialization:: *)
SetAttributes[Define, HoldAll];
Define[def_,defs__] := (Define[def]; Define[defs];);
Define[op_[is__]=\[ScriptCapitalE]_] := Module[{SD,ii,jj,kk,isp,nis,nisp,sis},Block[{i,j,k},
ReleaseHold[Hold[
SD[op[nisp,$k_Integer],Block[{i,j,k},op[isp,$k]=\[ScriptCapitalE];op[nis,$k]]];
SD[op[isp],op[{is},$k]];
SD[op[sis__],op[{sis}]];
]/. {SD->SetDelayed,
isp->{is}/.{i->i_,j->j_,k->k_},
nis->{is}/.{i->ii,j->jj,k->kk},
nisp->{is}/.{i->ii_,j->jj_,k->kk_}
}]  ]]


(* ::Input::Initialization:: *)
TriangularSolve[eqns_,vars_]:=Module[{sol={},e,v},
MapThread[
{e,v}|->sol=sol\[Union]First@Solve[e/.sol,v],
Flatten/@{eqns,vars}
];
sol
]


(* ::Input::Initialization:: *)
Subscript[\[CapitalLambda]2\[DoubleStruckCapitalE], d_->r_][\[CapitalLambda]_]:=Subscript[\[CapitalLambda]2\[DoubleStruckCapitalE], d->r][$k,\[CapitalLambda]];
Subscript[\[CapitalLambda]2\[DoubleStruckCapitalE], d_->r_][$k_,\[CapitalLambda]_]:=Module[{k},Subscript[\[DoubleStruckCapitalE], d->r]@@Table[SeriesCoefficient[\[CapitalLambda],{\[Epsilon],0,k}],{k,0,$k}]];


(* ::Input::Initialization:: *)
Subscript[BaseChange, n_][b1_->b2_]:=Module[{A,\[Alpha],\[Beta],lhs,rhs,eqns,\[Delta]\[Alpha],vars,sol,\[Zeta]},
A1=A2=IdentityMatrix[n];
Do[A1=A1 . MatrixExp[SparseArray[x1/.Subscript[x, \[Alpha]_,\[Beta]_]:>({\[Alpha],\[Beta]}->Subscript[\[Xi]1, \[Alpha],\[Beta]]),{n,n}]],{x1,b1}];
Do[A2=A2 . MatrixExp[SparseArray[x2/.Subscript[x, \[Alpha]_,\[Beta]_]:>({\[Alpha],\[Beta]}->Subscript[\[Xi]2, \[Alpha],\[Beta]]),{n,n}]],{x2,b2}];
solSS=Table[Subscript[\[Xi]2, \[Alpha],\[Alpha]]->Subscript[\[Xi]1, \[Alpha],\[Alpha]],{\[Alpha],n}];
eqns=Table[A1[[\[Alpha],\[Alpha]+\[Delta]\[Alpha]]]==A2[[\[Alpha],\[Alpha]+\[Delta]\[Alpha]]]/.solSS,{\[Delta]\[Alpha],1,n-1},{\[Alpha],1,n-\[Delta]\[Alpha]}];
vars=Table[Subscript[\[Xi]2, \[Alpha],\[Alpha]+\[Delta]\[Alpha]],{\[Delta]\[Alpha],1,n-1},{\[Alpha],1,n-\[Delta]\[Alpha]}];
Join[solSS,Simplify@TriangularSolve[eqns,vars] ]
];



