Pensieve header: A package for computations in general universal enveloping algebras.

Prolog

BeginPackage["UEA`"];
Print["UEA` does computations in general universal enveloping algebras and PBW algebras. It is in the public domain, available at http://drorbn.net/AcademicPensieve/Projects/UEA/. Dror Bar-Natan is committed to support it within reason until March 18, 2022. This is version 170507."];
Print["UEA` implements / extends ",
Sort@{"**", B, m, SetAlgebra, U, UB, UProducts, USimp, UU, $Basis, $PBWRule},
"."];
Begin["`Private`"];

Implementing general universal enveloping algebras

B[0,_]=0; B[_,0]=0;
B[c_*x_,y_]/; MemberQ[$Basis,x]:=Expand[c B[x,y]];
B[y_,c_*x_]/; MemberQ[$Basis,x]:=Expand[c B[y,x]];
B[x_Plus,y_] := B[#,y]& /@ x;
B[x_,y_Plus] := B[x,#]& /@ y;
B[x_,x_] =0;
B[y_,x_] := Expand[-B[x,y]];

x_⪯y_:=OrderedQ[{x,y}/.$PBWRule]; x_≺y_:=!OrderedQ[{y,x}/.$PBWRule];
(Subscript[UU, i_])[1] := (Subscript[U, i])[];
(Subscript[UU, i_])[((x_)^(p_))]:=(Subscript[UU, i])@@Table[x,{p}];
(Subscript[UU, i_])[ℰ_] := ℰ /. {
U[xs__] :> (Subscript[U, i])[xs],
x_ /; MemberQ[$Basis,x]:>(Subscript[U, i])[x]
};
(Subscript[UU, i_])[x_,xs__] := (Subscript[UU, t1])[x](Subscript[UU, t2])[xs] // Expand // (Subscript[m, t1,t2->i]);
USimp[ℰ_]:= Collect[ℰ, Times[(Subscript[U, _])[__]..], Expand];
USimp[ℰ_]:=Expand[ℰ];

(Subscript[m, s__])[0]=0;
(Subscript[m, s__])[x_Plus] := (Subscript[m, s])/@x;
(Subscript[m, s__])[sd_SeriesData] := MapAt[(Subscript[m, s]), sd, {3,All}];
(Subscript[m, i_->j_])[ℰ_] := ℰ /. (Subscript[U, i])->(Subscript[U, j]);

(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[x___](Subscript[U, j_])[]]:=c (Subscript[U, k])[x];
(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[](Subscript[U, j_])[y___]]:=c (Subscript[U, k])[y];
(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[xx___,x_](Subscript[U, j_])[y_,yy___]]:=If[x⪯y,
c (Subscript[U, k])[xx,x,y,yy],
(((Subscript[U, i])[xx]((Subscript[U, j])[y,x]+(Subscript[UU, j])[B[x,y]]) // Expand // (Subscript[m, i,j->i]))(Subscript[U, j])[yy] // Expand // (Subscript[m, i,j->k]))c // USimp
];

UProducts[{},0]={1}; UProducts[{},d_Integer] /; d>0 = {};
UProducts[{i_,is___}, d_Integer] := Sort@Flatten@Table[((Subscript[U, i])@@@Subsets[$Basis,{j}])u, {j,0,d},{u,UProducts[{is},d-j]}];

Supp[ℰ_]:= Union@Cases[{ℰ}, (Subscript[U, i_])[___]:>i, ∞];

Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
x_**y_ := Module[{is=Supp[x]⋂Supp[y],σ,z},
z=x; Do[z=(Subscript[m, i->σ@i])[z], {i,is}];
z=Expand[y z]; Do[z=(Subscript[m, σ@i,i->i])[z], {i,is}]; z];
UB[x_,y_] := USimp[x**y-y**x];

Epilog

End[]; EndPackage[];

Predefined Algebras

Print["UEA`SetAlgebra knows \"sl2\"."];

SetAlgebra["sl2"] := (
Print["In sl2: ⟨e,h,f⟩/([h,e]=2e, [h,f]=-2f, [e,f]=h)."];
B[h,e]=2e; B[h,f]=-2f; B[e,f]=h;
$Basis={e,h,f};
$PBWRule = {e->1,h->2,f->3};
);

Implementing ((t𝔤)^ϵ)=⟨b,e,g,f⟩/([g,e]=2e, [g,f]=-2f, [e,f]=b+ϵ g, [b,*]=0)

B[g,e]=2e; B[g,f]=-2f; B[e,f]=b+ϵ g;  B[b,_]=0;
$Basis={b,e,g,f};
$PBWRule = {b->1,e->2,g->3,f->4};

Table[{x,y}->B[x,y],{x,$Basis}, {y,$Basis}]// MatrixForm

Module[{x,y},Union@Table[{x,y}=t; B[x,y]+B[y,x],{t, Tuples[$Basis, 2]}]]

Module[{x,y,z}, DeleteCases[Table[
({x,y,z}=t)-> B[x,B[y,z]]+B[y,B[z,x]]+B[z,B[x,y]],
{t, Tuples[$Basis, 3]}
], _->0]]

Union[(u|->(Subscript[m, 1,3->1])[(Subscript[m, 1,2->1])[u]]-(Subscript[m, 1,2->1])[(Subscript[m, 2,3->2])[u]])/@UProducts[{1,2,3,4},4]]

(Subscript[r, i_,j_]):=USimp[(Subscript[U, i])[f](Subscript[U, j])[e]+(1/4)(-(ϵ^(-1))δ (Subscript[U, i])[b](Subscript[U, j])[b]+2 (Subscript[U, i])[b](Subscript[U, j])[g]+ϵ (Subscript[U, i])[g](Subscript[U, j])[g])+α((Subscript[U, i])[b](Subscript[U, j])[g]-(Subscript[U, i])[g](Subscript[U, j])[b])];
(Subscript[r, 1,2])

(Subscript[r, 1,2]) /. {δ->0, α->((-1)/4)}

(Subscript[r, 1,2]) /. {δ->0, α->((-1)/2)}

UB[(Subscript[r, 1,2]),(Subscript[r, 1,3])]+UB[(Subscript[r, 1,2]),(Subscript[r, 2,3])]+UB[(Subscript[r, 1,3]),(Subscript[r, 2,3])] // USimp

UB[(Subscript[r, 1,2]),(Subscript[r, 1,3])]

UB[(Subscript[r, 1,2]),(Subscript[r, 2,3])]

UB[(Subscript[r, 1,3]),(Subscript[r, 2,3])]

(Subscript[UU, 1])[(f^3),1,(e^2)]