Pensieve header: The PBW multiplication tensor for upper nilpotent matrices using the $\lambda$-tangent formalism. Some material from pensieve://Projects/UEA.

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

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/SolvablePBW/. Dror Bar-Natan is committed to support it within reason until June 1, 2027. This is version 260601."];
Print["UEA` implements / extends ",
Sort@{"**", B, m, SetAlgebra, U, UB, UProducts, USimp, UU, $Basis, $PBWRule,δ},
"."];
Begin["`Private`"];

Utilities

(Subscript[δ, i_,j_]):=If[i==j,1,0];

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

sl(2)

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};
);

(Subscript[un, n])

Print["UEA`SetAlgebra knows the nilpotent algebra (Subscript[un, n])."];

SetAlgebra[(Subscript[un, n_])] := (
$Basis=Flatten@Table[(Subscript[x, α,β]),{β,2,n},{α,1,β-1}];
$PBWRule = Thread[$Basis->Range@Length@$Basis];
B[(Subscript[x, i_,j_]),(Subscript[x, k_,l_])]:=(Subscript[δ, j,k])(Subscript[x, i,l])-(Subscript[δ, l,i])(Subscript[x, k,j]);
);

SetAlgebra[(Subscript[un, 5])];
$PBWRule
MatrixForm@Table[{b1,b2}->B[b1,b2],{b1,$Basis},{b2,$Basis}]

Clear[adPower];
adPower[x_,k_][0]=0;
adPower[x_,k_][c_*y_]/; MemberQ[$Basis,y]:=Expand[c adPower[x,k][y]];
adPower[x_,k_][y_Plus] := adPower[x,k]/@ y;
adPower[_,0][y_]:=y;
adPower[x_,k_][y_]/;MemberQ[$Basis,y]:=adPower[x,k][y]=B[adPower[x,k-1][y],x];

x0=($Basis/.x->ξ).$Basis;
y0=($Basis/.x->η).$Basis

adPower[x0,0][(Subscript[x, 1,2])]

B[(Subscript[x, 1,2]),x0]

adPower[x0,1][(Subscript[x, 1,2])]

adPower[x0,2][(Subscript[x, 1,2])]

adPower[x0,3][(Subscript[x, 1,2])]

adPower[x0,2][y0]

adPower[x0,3][y0]

adExp[x_][y_]:=Expand@Module[{k=0,s=0},
While[adPower[x,k][y]=!=0,
s+=adPower[x,k][y]/k!;
++k
];
s
]

adExp[x0][y0]

Coefficient[adExp[x0][y0], (Subscript[x, 1,5])]

λTangent[]=0;
λTangent[xs___,x_]:=adExp[x][λTangent[xs]]+(∂_λ)x;
λTangent[xs_List]:=λTangent@@xs

$Basis($Basis/.x->ξ)

λTangent@(λ $Basis($Basis/.x->ξ))

lhs=Join[λ $Basis($Basis/.x->ξ),λ $Basis($Basis/.x->η)]//λTangent

rhs=λTangent@($Basis($Basis/.(Subscript[x, αβ__])->(Subscript[f, αβ])[λ]))

(Coefficient[lhs-rhs,#]==0)&/@$Basis

{sol}=DSolve[
Join[
(Coefficient[lhs-rhs,#]==0)&/@$Basis,
$Basis/.(Subscript[x, αβ__]):>(Subscript[f, αβ])[0]==0
],
$Basis/.(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],
λ
]

sol/.λ->1

osol=(Subscript[𝔼, {1,2}->{2}])[(Subscript[x, 1,1])[2] (Subscript[ξ, 1,1])[1]+(Subscript[x, 1,1])[2] (Subscript[ξ, 1,1])[2]+(E^(-(Subscript[ξ, 1,1])[2])) (Subscript[x, 1,2])[2] (Subscript[ξ, 1,2])[1]+(E^(-(Subscript[ξ, 2,2])[1])) (Subscript[x, 1,2])[2] (Subscript[ξ, 1,2])[2]+(E^(-(Subscript[ξ, 1,1])[2])) (Subscript[x, 1,3])[2] (Subscript[ξ, 1,3])[1]+(E^(-(Subscript[ξ, 3,3])[1])) (Subscript[x, 1,3])[2] (Subscript[ξ, 1,3])[2]+(E^(-(Subscript[ξ, 1,1])[2])) (Subscript[x, 1,4])[2] (Subscript[ξ, 1,4])[1]+(E^(-(Subscript[ξ, 4,4])[1])) (Subscript[x, 1,4])[2] (Subscript[ξ, 1,4])[2]+(E^(-(Subscript[ξ, 1,1])[2])) (Subscript[x, 1,5])[2] (Subscript[ξ, 1,5])[1]+(E^(-(Subscript[ξ, 5,5])[1])) (Subscript[x, 1,5])[2] (Subscript[ξ, 1,5])[2]+(Subscript[x, 2,2])[2] (Subscript[ξ, 2,2])[1]+(Subscript[x, 2,2])[2] (Subscript[ξ, 2,2])[2]+(E^(-(Subscript[ξ, 2,2])[2])) (Subscript[x, 2,3])[2] (Subscript[ξ, 2,3])[1]-(Subscript[x, 1,3])[2] (Subscript[ξ, 1,2])[2] (Subscript[ξ, 2,3])[1]+(E^(-(Subscript[ξ, 3,3])[1])) (Subscript[x, 2,3])[2] (Subscript[ξ, 2,3])[2]+(E^(-(Subscript[ξ, 2,2])[2])) (Subscript[x, 2,4])[2] (Subscript[ξ, 2,4])[1]-(Subscript[x, 1,4])[2] (Subscript[ξ, 1,2])[2] (Subscript[ξ, 2,4])[1]+(E^(-(Subscript[ξ, 4,4])[1])) (Subscript[x, 2,4])[2] (Subscript[ξ, 2,4])[2]+(E^(-(Subscript[ξ, 2,2])[2])) (Subscript[x, 2,5])[2] (Subscript[ξ, 2,5])[1]-(Subscript[x, 1,5])[2] (Subscript[ξ, 1,2])[2] (Subscript[ξ, 2,5])[1]+(E^(-(Subscript[ξ, 5,5])[1])) (Subscript[x, 2,5])[2] (Subscript[ξ, 2,5])[2]+(Subscript[x, 3,3])[2] (Subscript[ξ, 3,3])[1]+(Subscript[x, 3,3])[2] (Subscript[ξ, 3,3])[2]+(E^(-(Subscript[ξ, 3,3])[2])) (Subscript[x, 3,4])[2] (Subscript[ξ, 3,4])[1]-(Subscript[x, 1,4])[2] (Subscript[ξ, 1,3])[2] (Subscript[ξ, 3,4])[1]-(Subscript[x, 2,4])[2] (Subscript[ξ, 2,3])[2] (Subscript[ξ, 3,4])[1]+(E^(-(Subscript[ξ, 4,4])[1])) (Subscript[x, 3,4])[2] (Subscript[ξ, 3,4])[2]+(E^(-(Subscript[ξ, 3,3])[2])) (Subscript[x, 3,5])[2] (Subscript[ξ, 3,5])[1]-(Subscript[x, 1,5])[2] (Subscript[ξ, 1,3])[2] (Subscript[ξ, 3,5])[1]-(Subscript[x, 2,5])[2] (Subscript[ξ, 2,3])[2] (Subscript[ξ, 3,5])[1]+(E^(-(Subscript[ξ, 5,5])[1])) (Subscript[x, 3,5])[2] (Subscript[ξ, 3,5])[2]+(Subscript[x, 4,4])[2] (Subscript[ξ, 4,4])[1]+(Subscript[x, 4,4])[2] (Subscript[ξ, 4,4])[2]+(E^(-(Subscript[ξ, 4,4])[2])) (Subscript[x, 4,5])[2] (Subscript[ξ, 4,5])[1]-(Subscript[x, 1,5])[2] (Subscript[ξ, 1,4])[2] (Subscript[ξ, 4,5])[1]-(Subscript[x, 2,5])[2] (Subscript[ξ, 2,4])[2] (Subscript[ξ, 4,5])[1]-(Subscript[x, 3,5])[2] (Subscript[ξ, 3,4])[2] (Subscript[ξ, 4,5])[1]+(E^(-(Subscript[ξ, 5,5])[1])) (Subscript[x, 4,5])[2] (Subscript[ξ, 4,5])[2]+(Subscript[x, 5,5])[2] (Subscript[ξ, 5,5])[1]+(Subscript[x, 5,5])[2] (Subscript[ξ, 5,5])[2],0,0][[1]]/.(Subscript[ξ, i_,i_])[_]->0

Expand@Total[sol/.{(Subscript[ξ, αβ__]):>(Subscript[ξ, αβ])[1],(Subscript[η, αβ__]):>(Subscript[ξ, αβ])[2] ,Rule->Times,λ->1,(Subscript[f, αβ__])[_]:>(Subscript[x, αβ])[2]}]-osol