Pensieve Header: Computations in the universal enveloping algebra of gl(*), with Emily Cliff and Iva Halacheva.

Unprotect[NonCommutativeMultiply];

b[E[s_,ij__], E[t_, kl__]] /; s≠t := 0;
b[E[s_,i_,j_], E[s_,k_,l_]] := KroneckerDelta[j,k]W[E[s,i,l]]-KroneckerDelta[i,l]W[E[s,k,j]];
b[_, _a] =0;
b[_a, _] = 0;
b[_, _q] =0;
b[_q, _] = 0;
b[x_,y_] := x**y-y**x;

PBWReduce[W[]] = RW[];
PBWReduce[W[e_, more___]] := W[e]**PBWReduce[W[more]];
PBWReduce[expr_] := Expand[expr /. w_W :> PBWReduce[w]];
_ ** 0 = 0;
x_ ** (c_?NumberQ*y_) := c(x**y);
x_ ** y_Plus := (x**#)& /@ y;
0**_ = 0;
(c_?NumberQ * y_)**x_ := c(y**x);
x_Plus ** y_ := (#**y)& /@ x;
W[w1___] ** W[w2___] := W[w1,w2];
W[e_] ** W[] := RW[e];
W[e_] ** RW[] := RW[e];

W[e_] ** RW[f_,more___] /; OrderedQ[{e,f}] := RW[e,f,more];
W[e_] ** RW[f_,more___] /; !OrderedQ[{e,f}] := Plus[
W[f]**(W[e]**RW[more]),
b[e,f]**RW[more]
];

Sh[0, l_] := { {l,{},Range[l]} };
Sh[k_, 0] := { {k,Range[k], {}} };
Sh[k_,l_] := Sh[k,l] = Join[
Replace[Sh[k-1, l]+1,{n_, {is___}, {js___}} :> {n, {1,is}, {js}}, {1}],
Replace[Sh[k, l-1]+1,{n_, {is___}, {js___}} :> {n, {is}, {1,js}}, {1}],
Replace[Sh[k-1,l-1]+1,{n_, {is___}, {js___}} :> {n, {1,is}, {1,js}}, {1}]
];

ReIndex[E[s_, i_, j_], is_List] := E[ s, is[[i]], is[[j]] ];
ReIndex[a[i_,j_], is_List] := a[ is[[i]], is[[j]] ];
ReIndex[q[i_,j_], is_List] := q[ is[[i]], is[[j]] ];

(S[k_]w1_W)**(S[l_]w2_W) := Total[
(
S[#[[1]]] NonCommutativeMultiply[
Replace[w1, e_ :> ReIndex[e, #[[2]]], {1}],
Replace[w2, e_ :> ReIndex[e, #[[3]]], {1}]
]
)& /@ Sh[k,l]
];

Act[ss_List, expr_] := expr /. E[s_, ij__] :> E[ss[[s]], ij];

r=Plus[
1/2 S[1]W[E[1,1,1], E[2,1,1]],
S[2]W[a[1,2], E[1,1,1],E[2,2,2]],
-S[2]W[a[1,2], E[2,1,1],E[1,2,2]],
S[2]W[E[1,2,1], E[2,1,2]]
];
CYBE[r_] := Plus[
b[Act[{1,2}, r], Act[{1,3},r]],
b[Act[{1,2}, r], Act[{2,3},r]],
b[Act[{1,3}, r], Act[{2,3},r]]
];

TStar[r_, diag_Diag] := TStar[r, diag] = PBWReduce[
PBWReduce[
NonCommutativeMultiply@@(diag /. ar[s1_, s2_] :> Act[{s1,s2}, r])
] /. {
E[s_, ij__] :> E[1, ij],
RW -> W
}
];
TStar[r_, expr_] := Expand[expr /. diag_Diag :> TStar[r, diag]];
TStar[expr_] := TStar[r, expr];

PBWReduce[S[2]W[E[1,2,1],E[2,1,2],E[1,2,1],E[3,1,2]]]

CYBE[r] // PBWReduce

PBWReduce[W[E[2,6,7],E[1,4,2], E[1,2,3]]]

PBWReduce[W[E[1,2,3], E[1,2,4]]]

PBWReduce[W[E[2,1,3],E[1,3,4]]]

Sh[2,3]

r

X=S[2]W[q[1,2], E[1,1,2]]

PBWReduce[b[Act[{1},X], r] + b[Act[{2}, X], r]]

Rels[2]

TStar[Rels[2]]

Rels[3]

TStar[Diag[ar[1,3],ar[4,2]]] /. RW[_E, ___] :> 0

Print[TStar[#]] & /@ Rels[3];

Length[BasisAArrow[3]]

im=TStar[BasisAArrow[3]]

TargetBasis = Union[Cases[
TStar[DomainBasis=BasisAArrow[3]] /. c_?NumberQ*rw_RW*n_S :> n*rw,
rw_RW*n_S,
Infinity
]]

rule= Thread[TargetBasis -> IdentityMatrix[Length[TargetBasis]]]

mat=(im /.  rule)

Dimensions[mat]

mat[[1]]

MatrixRank[Transpose[mat]]

a+2b /. Thread[{a,b,c} -> IdentityMatrix[3]]

r /. W[_a, ___] :> 0

TStar[Expand[2r /. W[_a, ___] :> 0], BasisAArrow[4]]