PBWReduce[W[]] = RW[];
PBWReduce[W[e_]] := RW[e];
PBWReduce[W[e_, more__]] := e**PBWReduce[W[more]];
PBWReduce[expr_] /; (Head[expr]=!=W) := Expand[
expr /. w_W :> PBWReduce[w]
];
Unprotect[NonCommutativeMultiply];
a_ ** 0 := 0;
a_ ** (c_?NumberQ*b_) := c(a**b);
x_ ** (c_a *y_) := c(x**y);
a_ ** b_Plus := (a**#)& /@ b;
0**a_ := 0;
(c_?NumberQ * b_)**a_ := c(b**a);
(c_a * x_)** y_ := c(x**y);
a_Plus ** b_ := (#**b)& /@ a;
W[w1___] ** W[w2___] := W[w1,w2];
e_E ** W[] := RW[e];
e_E ** RW[] := RW[e];
e_E ** RW[f_E,more___] /; OrderedQ[{e,f}] := RW[e,f,more];
E[a_,i_,j_] ** RW[E[b_,k_,l_], more___] /; a>b := E[b,k,l]**(E[a,i,j]**RW[more]);
E[a_,i_,j_]** RW[E[a_,k_,l_], more___] /; (i>k  || (i==k && j>l)) := Plus[
E[a,k,l] ** (E[a,i,j]**RW[more]),
KroneckerDelta[j,k]E[a,i,l]**RW[more],
-KroneckerDelta[i,l]E[a,k,j]**RW[more]
];
b[x_,y_] := x**y-y**x;
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}]
];
(S[k_]w1_W)**(S[l_]w2_W) := Total[
(
S[#[[1]]] NonCommutativeMultiply[
w1 /. {
E[a_,i_,j_] :> E[a, #[[2,i]], #[[2,j]]],
a[i_,j_] :> a[#[[2,i]], #[[2,j]]]
},
w2 /. {
E[a_,i_,j_] :> E[a, #[[3,i]], #[[3,j]]],
a[i_,j_] :> a[#[[3,i]], #[[3,j]]]
}
]
)& /@ Sh[k,l]
];
Act[as_List, expr_] := expr /. E[a_, ij__] :> E[as[[a]], ij];

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

r=Plus[
1/2 S[1]W[E[1,1,1], E[2,1,1]],
S[2]a[1,2]W[E[1,1,1],E[2,2,2]],
-S[2]a[1,2]W[E[2,1,1],E[1,2,2]],
S[2]W[E[1,2,1], E[2,1,2]]
];
CYBE[r_] := PBWReduce[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]]
]];CYBE[r]

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]a[1,2]W[E[1,1,2]]

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