Pensieve header: Implementing and verifying $gl_n^\epsilon$; with highlighted centre. Continues pensieve://2017-01/, continued pensieve://2020-01/.

(Subscript[h, here])=(Subscript[h, naive])-ϵg; (Subscript[h, naive])=(Subscript[h, here])+ϵg.

(Subscript[χ, cond_]) := If[TrueQ@cond, 1, 0];
B[0,_]=0; B[_,0]=0;
B[c_*x:(Subscript[(e|f|g|h), __]),y_]:=Expand[c B[x,y]];
B[y_,c_*x:(Subscript[(e|f|g|h), __])]:=Expand[c B[y,x]];
B[x_Plus,y_] := B[#,y]& /@ x;
B[x_,y_Plus] := B[x,#]& /@ y;
P[0,_]=0; P[_,0]=0;
P[c_*x:(Subscript[(e|f|g|h), __]),y_]:=Expand[c P[x,y]];
P[y_,c_*x:(Subscript[(e|f|g|h), __])]:=Expand[c P[y,x]];
P[x_Plus,y_] := P[#,y]& /@ x;
P[x_,y_Plus] := P[x,#]& /@ y;

P[(Subscript[e, i_,j_]), (Subscript[f, k_,l_])] := (Subscript[χ, j==k∧i==l]); P[(Subscript[f, k_,l_]), (Subscript[e, i_,j_])] := (Subscript[χ, j==k∧i==l]);
P[(Subscript[(e|f), __]),(Subscript[h, _])]=0; P[(Subscript[h, _]),(Subscript[(e|f), __])]=0;
P[(Subscript[g, i_]),(Subscript[h, j_])]:=2(Subscript[χ, i==j]); P[(Subscript[h, j_]),(Subscript[g, i_])]:=2(Subscript[χ, i==j]); P[(Subscript[h, i_]),(Subscript[h, j_])]:=-4ϵ (Subscript[χ, i==j]);
P[(Subscript[(e|g), __]),(Subscript[(e|g), __])]=0;
P[(Subscript[(f|g), __]),(Subscript[(f|g), __])]=0;

B[(Subscript[h, _]),_] = 0; B[(Subscript[g, _]),(Subscript[g, _])]= 0; 

B[(Subscript[e, i_,j_]),(Subscript[e, k_,l_])] := (Subscript[χ, j==k])(Subscript[e, i,l])-(Subscript[χ, l==i])(Subscript[e, k,j]);
B[(Subscript[f, i_,j_]),(Subscript[f, k_,l_])] := ϵ (Subscript[χ, j==k])(Subscript[f, i,l])-ϵ (Subscript[χ, l==i])(Subscript[f, k,j]);
B[(Subscript[e, i_,j_]),(Subscript[f, k_,l_])] := Expand[(Subscript[χ, j==k])(ϵ (Subscript[χ, i<l])(Subscript[e, i,l])+(Subscript[χ, i>l])(Subscript[f, i,l])) - (Subscript[χ, l==i])(ϵ (Subscript[χ, k<j])(Subscript[e, k,j])+(Subscript[χ, k>j])(Subscript[f, k,j]))+(Subscript[χ, j==k∧i==l])((1/2)((Subscript[h, i])-(Subscript[h, j]))+ϵ ((Subscript[g, i])-(Subscript[g, j])))];

B[(Subscript[g, i_]),(Subscript[e, j_,k_])] := ((Subscript[χ, i==j])-(Subscript[χ, i==k]))(Subscript[e, j,k]);
B[(Subscript[g, i_]),(Subscript[f, j_,k_])] := ((Subscript[χ, i==j])-(Subscript[χ, i==k]))(Subscript[f, j,k]);

B[y_,x_] := Expand[-B[x,y]];

(SuperPlus[Basis])[n_] := Union@Flatten@{Table[(Subscript[e, i,j]), {i,n-1}, {j,i+1,n}],Table[(Subscript[g, i]), {i,n}]};
(SuperMinus[Basis])[n_] := Union@Flatten@{Table[(Subscript[f, i,j]), {i,2,n}, {j,i-1}],Table[(Subscript[h, i]), {i,n}]};
Basis[n_] := Union[(SuperPlus[Basis])[n], (SuperMinus[Basis])[n]];

Basis[4]

n=3;
Table[
{x,y}->B[x,y],
{x,Basis[n]}, {y,Basis[n]}
]// MatrixForm

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

n=3;
DeleteCases[Flatten@Table[
{x,y,z}-> P[B[x,y],z]+P[y,B[x,z]],
{x,Basis[n]}, {y,Basis[n]},{z,Basis[n]}
], _->0]

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

$TD=∞; ℏ /: (ℏ^(d_. ))/;d>$TD :=0;

PBWRule={};
x_⪯y_:=OrderedQ[{x,y}/.PBWRule]; x_≺y_:=!OrderedQ[{y,x}/.PBWRule];
(Subscript[UU, i_])[ℰ_] := ℰ /. (Subscript[(x:e|f|g|h), s__]):>(Subscript[U, i])[(Subscript[x, s])];
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

-ϵ (Subscript[g, 1])+ϵ (Subscript[g, 2])-((Subscript[h, 1])/2)+((Subscript[h, 2])/2)+2(Subscript[e, 1,2]) // (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])[] (Subscript[U, 2])[(Subscript[g, 2]),(Subscript[g, 3])] (Subscript[U, 3])[(Subscript[e, 2,3])]]

(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])[a,a] (Subscript[U, 2])[c,d]+(a+b) (Subscript[U, 1])[a,b] (Subscript[U, 2])[c,d] // (Subscript[m, 1,2->3])

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

UProducts[1,{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[3,{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]

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