Pensieve header: Implementing the scapegoated VdV algebra of http://drorbn.net/bbs/show?shot=VanDerVeen-160731-121550.jpg.

ϵ=0;
PBWBasis={c,u,w};
B[U@c,U@w]=-(B[U@w,U@c]=U@w);
B[U@u,U@c]=-(B[U@c,U@u]=U@u);
B[U@w,U@u]=-(B[U@u,U@w]=(t-1)U[](*-ϵ U[u,w]+ϵ t U[]+2ϵ t U[c]*));

(Subscript[U, i_])[ℰ_] := ℰ /. {t->(Subscript[t, i]), u_U :> Replace[u, x_ :> (Subscript[x, i]),1]};

B[x_,x_]=0;
B[U[(Subscript[(x_), i_])],U[(Subscript[(y_), i_])]]:=(Subscript[U, i])[B[U@x,U@y]];
B[U[(Subscript[(x_), i_])],U[(Subscript[(y_), j_])]] /; i=!=j := 0;
B[x_,y_] := x**y-y**x;

x_⪯y_:=OrderedQ[{x,y}]; x_≺y_:=!OrderedQ[{y,x}];
Simp[ℰ_]:= Collect[ℰ, _U, Expand];

Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
0**_=_**0=0;
x_**U[]:=x; U[]**x_:=x;
(a_*x_U)**(b_*y_U) := If[a b === 0, 0, Simp[a b (x**y)]];
(a_*x_U)**y_ := Simp[a(x**y)]; x_**(a_*y_U) := Simp[a(x**y)];
(x_Plus)**y_ := (#**y)& /@ x; x_**(y_Plus) := (x**#)& /@ y;
U[x_]**U[y_] := (*U[x]**U[y] =*) If[x≺y, U[x,y], U[y,x]+B[U@x,U@y]];
U[x_] ** U[y1_,yy__] := (*U[x] ** U[y1,yy] =*)If[x⪯y1,U[x,y1,yy],(U@x**U@y1)**U@yy];
U[xx__,xn_]**U[yy__] := (*U[xx,xn]**U[yy] =*) U@xx**(U@xn**U@yy);

U[l___,((x_)^(n_)),r___]:= U[l,Sequence@@Table[x,{n}],r];
U[l___,1,r___]:= U[l,r];

LBasis[n_Integer] := LBasis[Range[n]];
LBasis[S_] := DeleteCases[0]@Module[{i,j,k,l}, SortBy[(# /. {ϵ->2,(Subscript[c, _])->2,(Subscript[u, _])->2,(Subscript[w, _])->2, U->Times})&][
Union@Flatten[{{U[],ϵ U[]},
Table[{U@(Subscript[c, i]),U@(Subscript[u, i]),U@(Subscript[w, i]),ϵ U@(Subscript[c, i]),ϵ U@(Subscript[u, i]),ϵ U@(Subscript[w, i])}, {i,S}],
Table[{U[(Subscript[u, i]),(Subscript[w, j])],ϵ U[(Subscript[u, i]),(Subscript[w, j])],ϵ U@@Sort@{(Subscript[c, i]),(Subscript[c, j])},ϵ U[(Subscript[c, i]),(Subscript[u, j])],ϵ U[(Subscript[c, i]),(Subscript[w, j])]}, {i,S}, {j,S}],
Table[{ϵ U[(Subscript[c, i]),(Subscript[u, j]),(Subscript[w, k])],ϵ U@@Sort@{(Subscript[u, i]),(Subscript[u, j]),(Subscript[w, k])},ϵ U@@Sort@{(Subscript[u, i]),(Subscript[w, j]),(Subscript[w, k])}}, {i,S}, {j,S},{k,S}],
Table[ϵ U@@Sort@{(Subscript[u, i]),(Subscript[u, j]),(Subscript[w, k]),(Subscript[w, l])}, {i,S}, {j,S},{k,S},{l,S}] }]
]]

BLBasis[n_Integer] := BLBasis[Range[n]];
BLBasis[S_] := DeleteCases[0]@Module[{i,j,k,l}, SortBy[(# /. {ϵ->2,(Subscript[c, _])->2,(Subscript[u, _])->2,(Subscript[w, _])->2, U->Times})&][
Union@Flatten[{{U[],ϵ U[]},
Table[{U@(Subscript[c, i]),ϵ U@(Subscript[c, i])}, {i,S}],
Table[{U[(Subscript[u, i]),(Subscript[w, j])],ϵ U[(Subscript[u, i]),(Subscript[w, j])],ϵ U@@Sort@{(Subscript[c, i]),(Subscript[c, j])}}, {i,S}, {j,S}],
Table[{ϵ U[(Subscript[c, i]),(Subscript[u, j]),(Subscript[w, k])]}, {i,S}, {j,S},{k,S}],
Table[ϵ U@@Sort@{(Subscript[u, i]),(Subscript[u, j]),(Subscript[w, k]),(Subscript[w, l])}, {i,S}, {j,S},{k,S},{l,S}] }]
]]

UExp[ℰ_,n_]:=Module[{t=U[],k}, U[]+Sum[((t=t**ℰ)/(k!)), {k,n}]]//Simp

ToDegree[n_][ℰ_] := Simp[ℰ] /. {ϵ->ℏ ϵ, (Subscript[b, i_]):>ℏ (Subscript[b, i]), (Subscript[t, i_]):>(E^(ℏ (Subscript[b, i]))),b->ℏ b,  t:>(E^(ℏ b)),x_U:>(ℏ^(Count[x,u|(Subscript[u, _])]))x} /. a_.x_U :>Series[a,{ℏ,0,n}]*x

Testing AS and Jacobi

B[U@w,U@c]

B[U@u,U@c]

B[U@w,U@u]

BLBasis[2]

bas=BLBasis[2];Table[B[x,y]+B[y,x], {x,bas},{y,bas}] //Flatten//Union

bas=BLBasis[2]; Timing[
Table[
{x,y,z}=xyz;
Simp[B[B[x,y],z]+B[B[y,z],x]+B[B[z,x],y]],
{xyz, Subsets[bas,{3}]}
] //Flatten//Union
]

Testing Yang-Baxter

R[i_,j_,d_]:= Module[{nn,p},
Sum[
Sum[nn=p-m;
(((Subscript[b, i])^m)/((m!)(nn!)))U[((Subscript[u, i])^nn),((Subscript[c, j])^m),((Subscript[w, j])^nn)],
{m,0,p}],
{p,0,d}
]
]

R[i,j,2]

R[i,j,3]

Series[((1-(E^(-(Subscript[b, 1]))))/(Subscript[b, 1])),{(Subscript[b, 1]),0,3}]

Simp[R[1,2,3]]//ToDegree[3]

Simp[R[1,2,3] /. x_U:>((((((Subscript[t, 1])-1)/(Subscript[b, 1]))))^(Count[x,(Subscript[u, 1])]))x]//ToDegree[3]

With[{d=2}, R[1,2,d]**R[1,3,d]**R[2,3,d] // ToDegree[d]]

R3[d_] := (R[1,2,d]**R[1,3,d]**R[2,3,d])-(R[2,3,d]**R[1,3,d]**R[1,2,d])

R3[1] // Simp // ToDegree[1]

R3[2] // ToDegree[2]

R3[2]// ToDegree[3]

With[{p=3},Sum[n=p-m;
(((Subscript[b, i])^m)/(m!n!))U[((Subscript[u, i])^n),((Subscript[c, j])^m),((Subscript[w, j])^n)],
{m,0,p}]]

B[U@u,U@w]

B[U@u,U@c]

With[{p=1},Sum[n=p-m;
(((Subscript[b, i])^m)/(m!n!))U[((Subscript[u, i])^n),((Subscript[c, j])^m),((Subscript[w, j])^n)],
{m,0,p}]]

(Subscript[a, i_,j_]):=(Subscript[b, i]) U[(Subscript[c, j])]+U[(Subscript[u, i]),(Subscript[w, j])]

B[(Subscript[a, 1,2]),(Subscript[a, 1,2])]+B[(Subscript[a, 1,2]),(Subscript[a, 2,3])]+B[(Subscript[a, 1,3]),(Subscript[a, 2,3])] // Simplify

B[(Subscript[a, 1,2]),(Subscript[a, 1,2])]+B[(Subscript[a, 1,2]),(Subscript[a, 2,3])]+B[(Subscript[a, 1,3]),(Subscript[a, 2,3])] // ToDegree[3]

{i,j}

b

n

Simp[Module[{nn,p},
Sum[
Sum[nn=p-m;
(((Subscript[b, i])^m)/((m!)(nn!)))U[((Subscript[u, i])^nn),((Subscript[c, j])^m),((Subscript[w, j])^nn)],
{m,0,p}],
{p,0,3}
]
]/. x_U:>(((((1-(Subscript[t, i]))/(Subscript[b, i]))))^(Count[x,(Subscript[u, i])]))x] // ToDegree[3]

R[i_,j_,d_]:= Module[{nn,p},
Sum[
Sum[nn=p-m;
(((Subscript[b, i])^m)/((m!)(nn!)))U[((Subscript[u, i])^nn),((Subscript[c, j])^m),((Subscript[w, j])^nn)],
{m,0,p}],
{p,0,d}
]
]

Simp[R[1,2,3] /. x_U:>(((((1-(Subscript[t, 1]))/(Subscript[b, 1]))))^(Count[x,(Subscript[u, 1])]))x]//ToDegree[3]

B[R[1,2,3],U@(Subscript[u, 1])]//ToDegree[3]

R[1,2,3]**U@(Subscript[u, 1])