(* ::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\\SolvablePBW";
<< KnotTheory`


(* ::Input::Initialization:: *)
$k=1; $U=QU; $E:={$k};
$trim:={\[Epsilon]^k_./;k>$k->0};
SetAttributes[{SS,SST},HoldAll];
Subscript[q, \[HBar]_]:=E^(\[Gamma] \[Epsilon] \[HBar]);
(* Upper to lower and lower to Upper: *)
U2l={\!\(
\*SubsuperscriptBox[\(B\), \(i_\), \(p_.\)] -> 
\*SuperscriptBox[\(E\), \(\(-p\)\ \[HBar]\ \[Gamma]\ 
\*SubscriptBox[\(b\), \(i\)]\)]\),B^p_.->E^(-p \[HBar] \[Gamma] 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\ \[Gamma]\ 
\*SubscriptBox[\(\[Alpha]\), \(i\)]\)]\),\[ScriptCapitalA]^p_.->E^(p \[Gamma] \[Alpha])}; 
l2U={E^(c_. Subscript[b, i_]+d_.):>\!\(
\*SubsuperscriptBox[\(B\), \(i\), \(\(-c\)/\((\[HBar]\ \[Gamma])\)\)] 
\*SuperscriptBox[\(E\), \(d\)]\),E^(c_. b+d_.):>B^(-c/(\[HBar] \[Gamma])) 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/\[Gamma]\)] 
\*SuperscriptBox[\(E\), \(d\)]\),E^(c_. \[Alpha]+d_.):>\[ScriptCapitalA]^(c/\[Gamma]) E^d,
E^\[ScriptCapitalE]_:>E^Expand@\[ScriptCapitalE]}; 
SS[\[ScriptCapitalE]_,op_]:=Collect[Normal@Series[\[ScriptCapitalE],{\[Epsilon],0,$k}],\[Epsilon],op];
SS[\[ScriptCapitalE]_]:=SS[\[ScriptCapitalE],Together];
SST[\[ScriptCapitalE]_,op___]:=SS[\[ScriptCapitalE]/.U2l,op];
Simp[\[ScriptCapitalE]_,op_]:=Collect[\[ScriptCapitalE],_CU|_QU,op];
Simp[\[ScriptCapitalE]_]:=Simp[\[ScriptCapitalE],SS[#,Expand]&];
SimpT[\[ScriptCapitalE]_]:=Collect[\[ScriptCapitalE],_CU|_QU,SST[#,Expand]&];
K\[Delta]/:Subscript[K\[Delta], i_,j_]:=If[i===j,1,0];
Subscript[c_Integer, k_Integer] := c+O[\[Epsilon]]^(k+1);


(* ::Input::Initialization:: *)
Unprotect[NonCommutativeMultiply]; Attributes[NonCommutativeMultiply]={};
(NCM=NonCommutativeMultiply)[x_] := x;
NCM[x_,y_,z__] := (x**y)**z;
0**_=_**0=0;
(x_Plus)**y_:=(#**y)&/@x; x_**(y_Plus):=(x**#)&/@y;
B[x_,x_]=0; B[x_,y_] := x**y-y**x;
B[x_,y_,e_]:=B[x,y,e]=B[x,y];


(* ::Input::Initialization:: *)
DeclareAlgebra[U_Symbol, opts__Rule] := Module[
{gp,sr,g,cp,M,pow,k=0,
gs=Generators /. {opts},
cs=Centrals /. {opts} /. Centrals -> {}
},
U[Generators]=gs;
(Subscript[#, U]=U@#)&/@gs;
gp=Alternatives@@gs; gp=gp|Subscript[gp, _];(* gens *)
sr=Flatten@Table[{g->++k, Subscript[g, i_]->{i,k}},{g,gs}]; (* sorting \[Rule] *) 
cp=Alternatives@@cs; (* cents *)
SetAttributes[M,HoldRest]; M[0,_]=0; M[a_,x_]:=a x;
CE[\[ScriptCapitalE]_]:=Collect[\[ScriptCapitalE],_U,Expand]/.E^x_:>E^Expand[x]/.$trim;
Subscript[U, i_][\[ScriptCapitalE]_]:=\[ScriptCapitalE]/.{t:cp:>Subscript[t, i],u_U:>(Subscript[#, i]&)/@u};
Subscript[U, i_][NCM[]]=pow[\[ScriptCapitalE]_,0]=U@{}=Subscript[1, U]=U[];
B[U@Subscript[(x_), i_],U@Subscript[(y_), i_]]:=Subscript[U, i]@B[U@x,U@y];
B[U@Subscript[(x_), i_],U@Subscript[(y_), j_]] /; i=!=j := 0;
B[U@y_,U@x_]:=CE[-B[U@x,U@y]];
x_**(c_. Subscript[1, U]):=CE[c x]; (c_. Subscript[1, U])**x_:=CE[c x];
(a_. U[xx___,x_])**(b_. U[y_,yy___]) :=If[OrderedQ[{x,y}/.sr],
CE@M[a b/.$trim,U[xx,x,y,yy]],
U@xx**CE@M[a b/.$trim,U@y**U@x+B[U@x,U@y,$E]]**U@yy ];
U@{c_.*(l:gp)^n_,r___}/;FreeQ[c, gp]:= CE[c U@Table[l,{n}]**U@{r}];
U@{c_.*l:gp,r___} := CE[c U[l]**U@{r}];
U@{c_,r___}/;FreeQ[c, gp]:= CE[c U@{r}];
U@{l_Plus, r___} := CE[U@{#,r}& /@ l];
U@{l_,r___} := U@{Expand[l],r};
U[\[ScriptCapitalE]_NonCommutativeMultiply]:=U/@\[ScriptCapitalE];
Subscript[\[DoubleStruckCapitalO], U][specs___,poly_] := Module[{sp,null,vs,us},
sp=Replace[{specs}, l_List:>Subscript[l, null], {1}];
vs=Join@@(First /@ sp);
us=Join@@(sp /. Subscript[l_, s_] :> (l/.Subscript[x_, i_]:>Subscript[x, s]));
CE[Total[
CoefficientRules[poly, vs] /. (p_->c_) :> c U@(us^p)
]] /. Subscript[x_, null]:>x];
Subscript[\[DoubleStruckCapitalO], U][specs___,\[DoubleStruckCapitalE][L_,Q_,P_]]:=Subscript[\[DoubleStruckCapitalO], U][specs,SS@Normal[P E^(L+Q)]];
pow[\[ScriptCapitalE]_,n_]:=pow[\[ScriptCapitalE],n-1]**\[ScriptCapitalE];
Subscript[\[DoubleStruckCapitalS], U][\[ScriptCapitalE]_,ss___Rule] := CE@Total[
CoefficientRules[\[ScriptCapitalE],First/@{ss}]/.(p_->c_):>c NCM@@MapThread[pow,{Last/@{ss},p}]];
Subscript[\[Sigma], rs___][c_.*u_U] := (c/.Subscript[(t:cp), j_]:>Subscript[t, j/.{rs}])U[List@@(u/.Subscript[v_, j_]:>Subscript[v, j/.{rs}])];
Subscript[m, j_->k_][c_.*u_U] := CE[((c/.Subscript[(t:cp), j]->Subscript[t, k])DeleteCases[u,Subscript[_, j|k]])**U@@Cases[u,Subscript[w_, j]:>Subscript[w, k]]**U@@Cases[u,Subscript[_, k]]];
U /: c_.*u_U*v_U := CE[c u**v];
Subscript[S, i_][c_.*u_U]:= CE[((c/.Subscript[S, i][U,Centrals])DeleteCases[u,Subscript[_, i]])**Subscript[U, i][NCM@@Reverse@Cases[u,Subscript[x_, i]:>S@U@x]]];
Subscript[\[CapitalDelta], i_->j_,k_][c_.*u_U]:= CE[((c/.Subscript[\[CapitalDelta], i->j,k][U,Centrals])DeleteCases[u,Subscript[_, i]])**(NCM@@Cases[u,Subscript[x_, i]:>Subscript[\[Sigma], 1->j,2->k]@\[CapitalDelta]@U@x] /. NCM[]->U[])]; ]


(* ::Input::Initialization:: *)
Subscript[Invert, U_][\[ScriptCapitalE]_]:= Module[{A,B,\[Beta]},(* \[ScriptCapitalE]=A U[]+\[Epsilon] B *)
A=Coefficient[\[ScriptCapitalE],Subscript[1, U]]/.\[Epsilon]->0;
B=CE[\[Epsilon]^-1 (\[ScriptCapitalE]-A Subscript[1, U])];
Subscript[\[DoubleStruckCapitalS], U][SS[(A+\[Epsilon] \[Beta])^-1],  \[Beta]->B]
]


(* ::Input::Initialization:: *)
{SuperStar[X],SuperStar[Y],SuperStar[Z],SuperStar[b],SuperStar[a],SuperStar[z],SuperStar[y],SuperStar[x],SuperStar[\[CapitalXi]],SuperStar[\[CapitalUpsilon]],SuperStar[\[CapitalOmega]],SuperStar[\[Beta]],SuperStar[\[Alpha]],SuperStar[\[Zeta]],SuperStar[\[Eta]],SuperStar[\[Xi]]}={\[CapitalXi],\[CapitalUpsilon],\[CapitalOmega],\[Beta],\[Alpha],\[Zeta],\[Eta],\[Xi],X,Y,Z,b,a,z,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:: *)
\[HBar]=\[Gamma]=1;
DeclareAlgebra[QU, Generators -> {X,Y,Z,b,a,z,y,x}, Centrals -> {s,t}];
B[Subscript[a, QU],Subscript[x, QU]]=-2 QU@x;
B[Subscript[b, QU],Subscript[x, QU]]=QU@x;
B[Subscript[b, QU],Subscript[y, QU]]=-2 QU@y;
B[Subscript[a, QU],Subscript[y, QU]]=QU@y;
B[Subscript[a, QU],Subscript[z, QU]]=-QU@z;
B[Subscript[b, QU],Subscript[z, QU]]=-QU@z;
B[Subscript[y, QU],Subscript[x, QU]]=-Subscript[z, QU]+\[Epsilon] \[HBar] QU[y,x];
B[Subscript[z, QU],Subscript[x, QU]]=-\[Epsilon] \[HBar] QU[z,x];
B[Subscript[b, QU],Subscript[a, QU]]=0;
B[Subscript[z, QU],Subscript[y, QU]]=\[Epsilon] \[HBar] QU[z,y];
B[Subscript[a, QU],Subscript[X, QU]]=2Subscript[X, QU];
B[Subscript[b, QU],Subscript[X, QU]]=-Subscript[X, QU];
B[Subscript[a, QU],Subscript[Y, QU]]=-Subscript[Y, QU];
B[Subscript[b, QU],Subscript[Y, QU]]=2Subscript[Y, QU];
B[Subscript[a, QU],Subscript[Z, QU]]=Subscript[Z, QU];
B[Subscript[b, QU],Subscript[Z, QU]]=Subscript[Z, QU];
B[Subscript[x, QU],Subscript[X, QU]]=-2\[Epsilon] \[HBar] QU@{X,x}+((1-s) QU[])/\[HBar]+2 s \[Epsilon] QU[a];
B[Subscript[y, QU],Subscript[Y, QU]]=-2\[Epsilon] \[HBar] QU@{Y,y}+((1-t) QU[])/\[HBar]+2 t \[Epsilon] QU[b];
B[Subscript[z, QU],Subscript[Z, QU]]=-2\[Epsilon] \[HBar] QU@{Z,z}+((1-s t) QU[])/\[HBar]+2 s t \[Epsilon] QU[a]+2 s t \[Epsilon] QU[b];
B[Subscript[y, QU],Subscript[Z, QU]]=Subscript[X, QU]-\[Epsilon] \[HBar] QU@{Z,y};
B[Subscript[x, QU],Subscript[Z, QU]]= -\[Epsilon] \[HBar] QU@{Z,x}-(s+s \[Epsilon] \[HBar]) QU[Y]+2s \[Epsilon] \[HBar] QU[Y,a];
B[Subscript[z, QU],Subscript[X, QU]]=2\[Epsilon] Subscript[y, QU]-\[Epsilon] \[HBar] QU@{X,z};
B[Subscript[z, QU],Subscript[Y, QU]]=-2t \[Epsilon] QU[x]-\[Epsilon] \[HBar] QU[Y,z];
B[Subscript[y, QU],Subscript[X, QU]]=\[Epsilon] \[HBar] QU[X,y];
B[Subscript[x, QU],Subscript[Y, QU]]=\[Epsilon] \[HBar] QU[Y,x];
B[Subscript[X, QU],Subscript[Y, QU]]=2\[Epsilon] Subscript[Z, QU]-\[Epsilon] \[HBar] QU[X,Y];B[Subscript[X, QU],Subscript[Z, QU]]=\[Epsilon] \[HBar] QU[X,Z];B[Subscript[Z, QU],Subscript[Y, QU]]=\[Epsilon] \[HBar] QU[Y,Z];


(* ::Input::Initialization:: *)
adPower[x_,k_,Env_][c_*y_QU]:=CE[c adPower[x,k,Env][y]];
adPower[x_,k_,Env_][y_Plus] := adPower[x,k,Env]/@ y;
adPower[_,0,Env_][y_]:=y;
adPower[x_,k_,Env_][0]=0;
adPower[x_,k_,Env_][y_QU]:=adPower[x,k,Env][y]=CE@B[adPower[x,k-1,Env][y],x];
adPower[x_,k_][y_]:=adPower[x,k,$E][y];


(* ::Input::Initialization:: *)
NilQ[Subscript[z, QU]]=NilQ[Subscript[Z, QU]]=NilQ[Subscript[X, QU]]=NilQ[Subscript[Y, QU]]=NilQ[Subscript[x, QU]]=NilQ[Subscript[y, QU]]=True; NilQ[Subscript[a, QU]]=False;NilQ[Subscript[b, QU]]=False;
PotQ[c_.*x_QU]:=\[Not]NilQ[x];  (* Potent Q *)
NilQ[c_*x_QU]:=NilQ[x];
PotQ[x_Plus]:=And@@(PotQ/@(List@@x));
NilQ[x_Plus]:=And@@(NilQ/@(List@@x));


(* ::Input::Initialization:: *)
Ad[0]=Identity;
Ad[c_. Subscript[a, QU]][z_]:=z/.w_QU:>E^(c \[Gamma] (Sum[B[Subscript[g, QU],Subscript[a, QU]]/Subscript[g, QU] Count[w,g],{g,QU@Generators}])) w;
Ad[c_. Subscript[b, QU]][z_]:=z/.w_QU:>E^(c \[Gamma] (Sum[B[Subscript[g, QU],Subscript[b, QU]]/Subscript[g, QU] Count[w,g],{g,QU@Generators}])) w;
Ad[c_. QU[]][z_]:=z;


(* ::Input::Initialization:: *)
Ad[x_][y_]/;NilQ[x]:=Expand@Module[{k=0,s=0},
While[adPower[x,k][y]=!=0,
s+=adPower[x,k][y]/k!;
++k
];
s
]


(* ::Input::Initialization:: *)
Subscript[TT, \[Lambda]_][]=0; (* Translated Tangent *)
Subscript[TT, \[Lambda]_][xs___,x_]:=CE[Ad[x][Subscript[TT, \[Lambda]][xs]]+\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Lambda]\)]x\)];
Subscript[TT, \[Lambda]_][xs_List]:=Subscript[TT, \[Lambda]]@@xs


(* ::Input::Initialization:: *)
Subscript[Seepage, U_][{},c_]=c;
Subscript[Seepage, U_][\[Xi]s_List,P_]:=Module[{gs=U[Generators],lx},
lx=gs[[Length@\[Xi]s]];
Collect[P,lx,(Ad[Last[\[Xi]s]Subscript[lx, U]][Subscript[\[DoubleStruckCapitalO], U][gs,Subscript[Seepage, U][Most@\[Xi]s,#]]]/.U->Times)&]
]



