Pensieve header: Implementing ${\mathcal U}(sl_2)$. Borrows from pensieve://2017-02/nb/glne.pdf.

B[0,_]=0; B[_,0]=0;
B[c_*x:(c|e|f|h),y_]:=Expand[c B[x,y]];
B[y_,c_*x:(c|e|f|h)]:=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]];

B[h,e]=2e; B[h,f]=-2f; B[e,f]=h;  B[c,_]=0;
Basis[] :={c,e,f,h};

Basis[]

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

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

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]

PBWRule={};
x_⪯y_:=OrderedQ[{x,y}/.PBWRule]; x_≺y_:=!OrderedQ[{y,x}/.PBWRule];
(Subscript[UU, i_])[ℰ_] := ℰ /. (x:c|e|f|h):>(Subscript[U, i])[x];
Simp[ℰ_]:= Collect[ℰ, Times[(Subscript[U, _])[__]..], Expand];
Simp[ℰ_]:=Expand[ℰ];

a (Subscript[U, 1])[a,b](Subscript[U, 2])[c,d]+b (Subscript[U, 1])[a,b](Subscript[U, 2])[c,d]+c (Subscript[U, 1])[a,a](Subscript[U, 2])[c,d]+a (Subscript[U, 1])[a,c]+b (Subscript[U, 1])[a,c]// Simp

e+f// (Subscript[UU, 3])

(Subscript[m, s__])[0]=0; (Subscript[m, s__])[x_Plus] := (Subscript[m, s])/@x;
(Subscript[m, i_->j_])[ℰ_] := ℰ /. (Subscript[U, i])->(Subscript[U, j]);

(Subscript[m, 1->4])[(Subscript[U, 1])[e,f] (Subscript[U, 2])[e,f] (Subscript[U, 3])[f]]

(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 // Simp
];

c (Subscript[U, 1])[e,f] (Subscript[U, 2])[e,e,f]+(a+b) (Subscript[U, 1])[h] (Subscript[U, 2])[f,f] // (Subscript[m, 1,2->3])

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

UProducts[{1},1]

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},3]]

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

Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
x_**y_ := Module[{is=S[x]⋂S[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_] := Simp[x**y-y**x];

{x=RandomChoice[UProducts[{1,2},3]], y=RandomChoice[UProducts[{1,2,3},3]], x**y}

(Subscript[r, i_,j_]):=(Subscript[U, i])[e](Subscript[U, j])[f]+(1/4) (Subscript[U, i])[h](Subscript[U, j])[h]+α (Subscript[U, i])[h](Subscript[U, j])[c]-α (Subscript[U, i])[c](Subscript[U, j])[h];

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