(* ::Package:: *)

(************************************************************************)
(* 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 Initialization 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.                                                         *)
(************************************************************************)



(* ::Input::Initialization:: *)
Date[]
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\FullDoPeGDO"];
Once[<<KnotTheory`];
Once[Get@"../Profile/Profile.m"];
$k=1;
<<Objects.m
<<KT.m


(* ::Input::Initialization:: *)
CCF[\[ScriptCapitalE]_] := Subscript[PP, CCF]@ExpandDenominator@ExpandNumerator@Together[\[ScriptCapitalE]]; (*Coefficient Canonical Form *)
CF[\[ScriptCapitalE]_] := Subscript[PP, CF]@Module[
{vs=Cases[\[ScriptCapitalE],Subscript[(y|a|x|\[Eta]|\[Beta]|\[Tau]|\[Xi]), _],\[Infinity]]\[Union]{y,a,x,\[Eta],\[Beta],\[Tau],\[Xi]}},
Total[(CCF[#[[2]]](Times@@(vs^#[[1]])))& /@ CoefficientRules[\[ScriptCapitalE], vs]]
];
CF[\[ScriptCapitalE]_\[DoubleStruckCapitalE]]:=CF/@\[ScriptCapitalE]; 
CF[\[ScriptCapitalE]_List]:=CF/@\[ScriptCapitalE]; 
CF[Subscript[\[DoubleStruckCapitalE], sp___][\[ScriptCapitalE]s___]]:=CF/@Subscript[\[DoubleStruckCapitalE], sp][\[ScriptCapitalE]s];


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


(* ::Input::Initialization:: *)
Clear[Wt];
Evaluate[Wt/@{y,b,t,a,x,\[Eta],\[Beta],\[Tau],\[Alpha],\[Xi]}]={1,0,0,2,1,1,2,2,0,1};
Wt[Subscript[u_, i_]]:=Wt[u];


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


(* ::Input::Initialization:: *)
U2l[\[ScriptCapitalE]_]:=\[ScriptCapitalE]/.{\!\(
\*SubsuperscriptBox[\(B\), \(i_\), \(p_.\)] :> 
\*SuperscriptBox[\(E\), \(\(-p\)\ \[HBar]\ 
\*SubscriptBox[\(b\), \(i\)]\)]\),B^p_.:>E^(-p \[HBar] b), \!\(
\*SubsuperscriptBox[\(T\), \(i_\), \(p_.\)] :> 
\*SuperscriptBox[\(E\), \(p\ \[HBar]\ 
\*SubscriptBox[\(t\), \(i\)]\)]\),T^p_.:>E^(p \[HBar] t),\!\(
\*SubsuperscriptBox[\(\[ScriptCapitalA]\), \(i_\), \(p_.\)] :> 
\*SuperscriptBox[\(E\), \(p\ 
\*SubscriptBox[\(\[Alpha]\), \(i\)]\)]\),\[ScriptCapitalA]^p_.:>E^(p \[Alpha])}; 
l2U[\[ScriptCapitalE]_]:=\[ScriptCapitalE]//.{E^(c_. Subscript[b, i_]+d_.):>\!\(
\*SubsuperscriptBox[\(B\), \(i\), \(\(-c\)/\[HBar]\)] 
\*SuperscriptBox[\(E\), \(d\)]\),E^(c_. b+d_.):>B^(-c/\[HBar]) E^d,E^(c_. Subscript[t, i_]+d_.):>\!\(
\*SubsuperscriptBox[\(T\), \(i\), \(c/\[HBar]\)] 
\*SuperscriptBox[\(E\), \(d\)]\),E^(c_. t+d_.):>T^(c/\[HBar]) E^d,
E^(c_. Subscript[\[Alpha], i_]+d_.):>\!\(
\*SubsuperscriptBox[\(\[ScriptCapitalA]\), \(i\), \(c\)] 
\*SuperscriptBox[\(E\), \(d\)]\),E^(c_. \[Alpha]+d_.):>\[ScriptCapitalA]^c E^d,E^\[ScriptCapitalX]_:>E^Expand@\[ScriptCapitalX]};
l2U[r_Rule]:=Module[{U=r[[1]]/.{b->B,t->T,\[Alpha]->\[ScriptCapitalA]}},U->l2U[U2l[U]/.r]];
AlsoUpper[rs_List] := rs\[Union](l2U/@rs);


(* ::Input::Initialization:: *)
Subscript[D, b][f_]:=\!\(
\*SubscriptBox[\(\[PartialD]\), \(b\)]f\)-\[HBar] B \!\(
\*SubscriptBox[\(\[PartialD]\), \(B\)]f\); Subscript[D, Subscript[b, i_]][f_]:=\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(i\)]]f\)-\[HBar] Subscript[B, i]\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(B\), \(i\)]]f\);
Subscript[D, t][f_]:=\!\(
\*SubscriptBox[\(\[PartialD]\), \(t\)]f\)+\[HBar] T \!\(
\*SubscriptBox[\(\[PartialD]\), \(T\)]f\); Subscript[D, Subscript[t, i_]][f_]:=\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(t\), \(i\)]]f\)+\[HBar] Subscript[T, i]\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(T\), \(i\)]]f\); 
Subscript[D, \[Alpha]][f_]:=\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Alpha]\)]f\)+\[ScriptCapitalA] \!\(
\*SubscriptBox[\(\[PartialD]\), \(\[ScriptCapitalA]\)]f\); Subscript[D, Subscript[\[Alpha], i_]][f_]:=\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(\[Alpha]\), \(i\)]]f\)+Subscript[\[ScriptCapitalA], i] \!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(\[ScriptCapitalA]\), \(i\)]]f\);
Subscript[D, v_][f_]:=\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]f\);


(* ::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},
lvs=Flatten@Table[{Subscript[y, $@i],Subscript[b, $@i],Subscript[t, $@i],Subscript[a, $@i],Subscript[x, $@i]},{i,is}];
Subscript[\[DoubleStruckCapitalE], (d1\[Union]Complement[d2,is])->(r2\[Union]Complement[r1,is])]@@(Subscript[Zip, lvs\[Union]SuperStar[lvs]][{SuperStar[lvs] . lvs,Times[
\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]/.Table[Subscript[(v:b|B|t|T|a|x|y), i]->Subscript[v, $@i],{i,is}],
\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]/.Table[Subscript[(v:\[Beta]|\[Tau]|\[Alpha]|\[ScriptCapitalA]|\[Xi]|\[Eta]), i]->Subscript[v, $@i],{i,is}]
]}])
]


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


(* ::Input::Initialization:: *)
Subscript[Zip, vs_][{\[ScriptCapitalF]_,\[ScriptCapitalE]_}]:={\[ScriptCapitalF],\[ScriptCapitalE]}//Subscript[Zip1, vs]//Subscript[Zip2, Select[vs,(0<Wt[#]<$n)&]]//Subscript[Zip3, Select[vs,(0<Wt[#]<$n)&]]//Subscript[Zip2, Select[vs,(Wt[#]==0\[Or]Wt[#]==$n)&]]//Subscript[Zip3, Select[vs,(Wt[#]==0\[Or]Wt[#]==$n)&]]//Last;


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


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


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


(* ::Input::Initialization:: *)
Subscript[EZip3, vs_]@{\[ScriptCapitalF]_,\[ScriptCapitalE]_\[DoubleStruckCapitalE]} := Subscript[PP, EZip3]@Module[
{n\[ScriptCapitalE],n\[ScriptCapitalF],j=0,ps,rr={(*release rules*)}},
n\[ScriptCapitalE]=Total[
CoefficientRules[#, vs] /. (ps_->c_) :> (AppendTo[rr,c\[ScriptCapitalE][++j]->c]; c\[ScriptCapitalE][j](Times@@(vs^ps)))
]& /@ \[ScriptCapitalE];
n\[ScriptCapitalF]=Total[CoefficientRules[\[ScriptCapitalF], SuperStar[vs]] /. (ps_->c_) :> (AppendTo[rr,c\[ScriptCapitalF][++j]->c]; c\[ScriptCapitalF][j](Times@@((SuperStar[vs])^ps)))];
CF[Expand[{n\[ScriptCapitalF],n\[ScriptCapitalE]}//Subscript[Zip3, vs]]/.rr]
]



