Hidden TEX

\documentclass[12pt,reqno]{amsart}
\usepackage[export]{adjustbox} % This also includes graphicx.
\usepackage{needspace}
\usepackage[textwidth=7.5in,textheight=10in,centering]{geometry}
\pagestyle{empty}

\def\nbpdfInput#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfEcho#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfPrint#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfText#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfMessage#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfOutput#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfSection#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfSubsection#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfSubsubsection#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfgraphInput#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfgraphOutput#1{\vskip 1mm\par\noindent\includegraphics[width=1.5in]{#1}}

\begin{document}

A Timing Game

CurrentValue[EvaluationNotebook[],EvaluationCompletionAction]={"ShowTiming"};

SetOptions[EvaluationNotebook[],StyleDefinitions->Notebook[{Cell[StyleData[StyleDefinitions->"Default.nb"]],Cell[StyleData["Input"],CellEpilog:>With[{time=AbsoluteCurrentValue["WindowStatusArea"]},If[CurrentValue[NextCell[],CellStyle]==={"Output"},SetOptions[NextCell[],CellLabel->time<>" Out["<>ToString[$Line-1]<>"]="]]]]},StyleDefinitions->"PrivateStylesheetFormatting.nb"]]

Headers

Pensieve header: An isolated attempt to compute the multiplication tensor of ${\mathcal U}_q(sl^+_{3,\epslion})$. Continues SjabboQUSL3Seepage.nb.

The implementation of QU is modified from pensieve://Projects/SL2Portfolio/SL2PortfolioProgram.nb.

SetDirectory@"C:\\drorbn\\AcademicPensieve\\Projects\\SolvablePBW";
<< KnotTheory`

nb2tex

Get["../nb2tex/nb2tex.m"];
nb2tex["Qsl3+eps", PDFWidth->7.5,PDFFolder->"Snips/Qsl3+eps"];
texfile=OpenAppend["Qsl3+eps.tex"]; WriteLine[texfile,"\\end{document}"]; Close[texfile];
Run@"\"C:\\Users\\drorb\\AppData\\Local\\Programs\\MiKTeX\\miktex\\bin\\x64\\pdflatex.exe\" Qsl3+eps.tex";

Initialization / Utilities

$k=1; $U=QU; $E:={$k};
$trim:={(ϵ^(k_.))/;k>$k->0};
SetAttributes[{SS,SST},HoldAll];
(Subscript[q, ℏ_]):=(E^(γ ϵ ℏ));
(* Upper to lower and lower to Upper: *)
U2l={(Subscript[B, i_]^(p_.))->(E^(-p ℏ γ (Subscript[b, i]))),(B^(p_.))->(E^(-p ℏ γ b)), (Subscript[T, i_]^(p_.))->(E^(p ℏ (Subscript[t, i]))),(T^(p_.))->(E^(p ℏ t)),(Subscript[𝒜, i_]^(p_.))->(E^(p γ (Subscript[α, i]))),(𝒜^(p_.))->(E^(p γ α))}; 
l2U={(E^(c_.(Subscript[b, i_])+d_.)):>(Subscript[B, i]^(-c/(ℏ γ)))(E^d),(E^(c_.b+d_.)):>(B^(-c/(ℏ γ)))(E^d),
(E^(c_.(Subscript[t, i_])+d_.)):>(Subscript[T, i]^(c/ℏ))(E^d),(E^(c_.t+d_.)):>(T^(c/ℏ))(E^d),
(E^(c_.(Subscript[α, i_])+d_.)):>(Subscript[𝒜, i]^(c/γ))(E^d),(E^(c_.α+d_.)):>(𝒜^(c/γ))(E^d),
(E^(ℰ_)):>(E^(Expand@ℰ))}; 
SS[ℰ_,op_]:=Collect[Normal@Series[ℰ,{ϵ,0,$k}],ϵ,op];
SS[ℰ_]:=SS[ℰ,Together];
SST[ℰ_,op___]:=SS[ℰ/.U2l,op];
Simp[ℰ_,op_]:=Collect[ℰ,_CU|_QU,op];
Simp[ℰ_]:=Simp[ℰ,SS[#,Expand]&];
SimpT[ℰ_]:=Collect[ℰ,_CU|_QU,SST[#,Expand]&];
Kδ/:(Subscript[Kδ, i_,j_]):=If[i===j,1,0];
(Subscript[c_Integer, k_Integer]) := c+((O[ϵ])^(k+1));

DeclareAlgebra

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];

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 -> *) 
cp=Alternatives@@cs; (* cents *)
SetAttributes[M,HoldRest]; M[0,_]=0; M[a_,x_]:=a x;
CE[ℰ_]:=Collect[ℰ,_U,Expand]/.(E^(x_)):>(E^(Expand[x]))/.$trim;
(Subscript[U, i_])[ℰ_]:=ℰ/.{t:cp:>(Subscript[t, i]),u_U:>((Subscript[#, i])&)/@u};
(Subscript[U, i_])[NCM[]]=pow[ℰ_,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[ℰ_NonCommutativeMultiply]:=U/@ℰ;
(Subscript[𝕆, 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[𝕆, U])[specs___,𝔼[L_,Q_,P_]]:=(Subscript[𝕆, U])[specs,SS@Normal[P (E^(L+Q))]];
pow[ℰ_,n_]:=pow[ℰ,n-1]**ℰ;
(Subscript[𝕊, U])[ℰ_,ss___Rule] := CE@Total[
CoefficientRules[ℰ,First/@{ss}]/.(p_->c_):>c NCM@@MapThread[pow,{Last/@{ss},p}]];
(Subscript[σ, 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[Δ, i_->j_,k_])[c_.*u_U]:= CE[((c/.(Subscript[Δ, i->j,k])[U,Centrals])DeleteCases[u,(Subscript[_, i])])**(NCM@@Cases[u,(Subscript[x_, i]):>(Subscript[σ, 1->j,2->k])@Δ@U@x] /. NCM[]->U[])]; ]

(Subscript[Invert, U_])[ℰ_]:= Module[{A,B,β},(* ℰ=A U[]+ϵ B *)
A=Coefficient[ℰ,(Subscript[1, U])]/.ϵ->0;
B=CE[(ϵ^(-1))(ℰ-A (Subscript[1, U]))];
(Subscript[𝕊, U])[SS[(((A+ϵ β))^(-1))],  β->B]
]

Implementing QU=(Subscript[𝒰, q])((Subscript[sl, 3,γϵ]^(+)))

Greek - Latin duality:

{(SuperStar[X]),(SuperStar[Y]),(SuperStar[Z]),(SuperStar[b]),(SuperStar[a]),(SuperStar[z]),(SuperStar[y]),(SuperStar[x]),(SuperStar[Ξ]),(SuperStar[Υ]),(SuperStar[Ω]),(SuperStar[β]),(SuperStar[α]),(SuperStar[ζ]),(SuperStar[η]),(SuperStar[ξ])}={Ξ,Υ,Ω,β,α,ζ,η,ξ,X,Y,Z,b,a,z,y,x}; 
(SuperStar[((Subscript[u_, αβ__]))]):=(Subscript[((SuperStar[u])), αβ]);
(SuperStar[((u:((y|x|η|ξ)|(Subscript[(y|x|η|ξ), __])))[i_])]):=(SuperStar[u])[i];
(SuperStar[(vs_List)]):=(v|->(SuperStar[v]))/@vs;

ℏ=γ=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])+ϵ ℏ QU[y,x];
B[(Subscript[z, QU]),(Subscript[x, QU])]=-ϵ ℏ QU[z,x];
B[(Subscript[b, QU]),(Subscript[a, QU])]=0;
B[(Subscript[z, QU]),(Subscript[y, QU])]=ϵ ℏ QU[z,y];
B[(Subscript[a, QU]),(Subscript[X, QU])]=2(Subscript[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])]=2(Subscript[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ϵ ℏ QU@{X,x}+(((1-s) QU[])/ℏ)+2 s ϵ QU[a];
B[(Subscript[y, QU]),(Subscript[Y, QU])]=-2ϵ ℏ QU@{Y,y}+(((1-t) QU[])/ℏ)+2 t ϵ QU[b];
B[(Subscript[z, QU]),(Subscript[Z, QU])]=-2ϵ ℏ QU@{Z,z}+(((1-s t) QU[])/ℏ)+2 s t ϵ QU[a]+2 s t ϵ QU[b];
B[(Subscript[y, QU]),(Subscript[Z, QU])]=(Subscript[X, QU])-ϵ ℏ QU@{Z,y};
B[(Subscript[x, QU]),(Subscript[Z, QU])]= -ϵ ℏ QU@{Z,x}-(s+s ϵ ℏ) QU[Y]+2s ϵ ℏ QU[Y,a];
B[(Subscript[z, QU]),(Subscript[X, QU])]=2ϵ (Subscript[y, QU])-ϵ ℏ QU@{X,z};
B[(Subscript[z, QU]),(Subscript[Y, QU])]=-2t ϵ QU[x]-ϵ ℏ QU[Y,z];
B[(Subscript[y, QU]),(Subscript[X, QU])]=ϵ ℏ QU[X,y];
B[(Subscript[x, QU]),(Subscript[Y, QU])]=ϵ ℏ QU[Y,x];
B[(Subscript[X, QU]),(Subscript[Y, QU])]=2ϵ (Subscript[Z, QU])-ϵ ℏ QU[X,Y];B[(Subscript[X, QU]),(Subscript[Z, QU])]=ϵ ℏ QU[X,Z];B[(Subscript[Z, QU]),(Subscript[Y, QU])]=ϵ ℏ QU[Y,Z];

QU@Generators

$Basis=QU/@QU@Generators;
Module[{a,b},Table[{a,b}->CE[B[a,b]],{a,$Basis},{b,$Basis}]] //MatrixForm

Module[{a,b,c},
DeleteCases[Flatten[Table[{a,b,c}->CE[B[a,B[b,c]]+B[b,B[c,a]]+B[c,B[a,b]]],{a,$Basis},{b,$Basis},{c,$Basis}]], _->0]
]

The Multiplication Tensor

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];

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]:=¬NilQ[x];  (* Potent Q *)
NilQ[c_*x_QU]:=NilQ[x];
PotQ[x_Plus]:=And@@(PotQ/@(List@@x));
NilQ[x_Plus]:=And@@(NilQ/@(List@@x));

Ad[0]=Identity;
Ad[c_.(Subscript[a, QU])][z_]:=z/.w_QU:>(E^(c γ (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 γ (Sum[((B[(Subscript[g, QU]),(Subscript[b, QU])])/(Subscript[g, QU]))Count[w,g],{g,QU@Generators}])))w;
Ad[c_.QU[]][z_]:=z;

Table[SeriesCoefficient[Ad[c (Subscript[a, QU])][(Subscript[g, QU])],{c,0,1}]-
B[(Subscript[g, QU]),(Subscript[a, QU])],{g,Generators//QU}]
Table[SeriesCoefficient[Ad[c (Subscript[b, QU])][(Subscript[g, QU])],{c,0,1}]-
B[(Subscript[g, QU]),(Subscript[b, QU])],{g,Generators//QU}]

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
]

(Subscript[TT, λ_])[]=0; (* Translated Tangent *)
(Subscript[TT, λ_])[xs___,x_]:=CE[Ad[x][(Subscript[TT, λ])[xs]]+(∂_λ)x];
(Subscript[TT, λ_])[xs_List]:=(Subscript[TT, λ])@@xs

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

$k=1

TTL=CE[(Subscript[TT, λ])@@(Flatten@Table[
(If[PotQ[(Subscript[#, QU])],1,λ](SuperStar[#])[k](Subscript[#, QU]))&/@QU@Generators,
{k,{i,j}}
])]

mons[k_]:=Union@Cases[Coefficient[TTL,ϵ,k],_QU,∞];
mons/@Range[0,$k]

ff=Table[
Sum[(ϵ^k)(Subscript[f, k,u])[λ],{k,0,$k}],
{u,QU@Generators}
]/.(Subscript[f, 0,u_])[λ]/;PotQ[(Subscript[u, QU])]:>(SuperStar[u])[i]+(SuperStar[u])[j]

Short[fs=Flatten[Table[
(Subscript[f, k,Times@@m]),
{k,0,$k},{m,mons[k]}
]],10]

gg=Sum[
(ϵ^k)(Subscript[f, k,Times@@u])[λ]Times@@u,
{k,0,$k},{u,Complement[mons[k],QU/@QU@Generators]}
]

G=SS[(E^gg)]

𝒮[B_]:=CE[SS@(Subscript[𝕆, QU])[QU@Generators,(Subscript[Seepage, QU])[ff,SS@CE@B]]];

Short[𝒮G=𝒮[G],10]

Short[(Subscript[Invert, QU])[𝒮G],10]

CE[(Subscript[Invert, QU])[𝒮G]**𝒮G]

Short[CE[((∂_λ)(ff.QU@Generators)G+(∂_λ)G)],10]

Length@CE[((∂_λ)(ff.QU@Generators)G+(∂_λ)G)]

𝒮[CE[((∂_λ)(ff.QU@Generators)G+(∂_λ)G)]]

TTR=CE[(Subscript[Invert, QU])[𝒮G]**𝒮[((∂_λ)(ff.QU@Generators)G+(∂_λ)G)]]

Cases[TTR,x_QU,Infinity]//Sort
Cases[TTL,x_QU,Infinity]//Sort

Short[diff=CE[TTL-TTR],10];

Short[eqns=Flatten[Table[
Coefficient[Coefficient[diff,m], ϵ,k]==0,
{k,0,$k},{m,mons[k]}
]],10];

Short[inits=(#[0]==0)&/@fs,10];

DSolve[eqns⋃inits,fs,λ]