Implementing (Subscript[g, 0]) for (Subscript[sl, 3]) (Quantum algebra)

(*Orig:  { (Subscript[(SuperPlus[X]), 1]),  (Subscript[(SuperPlus[X]), 2]),   (Subscript[(SuperPlus[X]), 3]), (Subscript[(SuperPlus[H]), 1]),   (Subscript[(SuperPlus[H]), 2]),  (Subscript[(SuperMinus[H]), 2]),  (Subscript[(SuperMinus[H]), 1]),   (Subscript[(SuperMinus[X]), 3]),  (Subscript[(SuperMinus[X]), 2]),   (Subscript[(SuperMinus[X]), 1])};
          {X,    Y,    Z,   A,    B,    b,    a,    z,    y,     x};
A,B central. (e^((2A-B)))=s, (e^((-A+2B)))=t*)
PBWBasis = {X,Y,Z,b,a,z,y,x};
PBWRule={X->1,Y->2,Z->3,b->4,a->5,z->6,y->7,x->8};
Br[U@X,U@Y]=0;
Br[U@X,U@Z]=0;
Br[U@X,U@b]=U@X;
Br[U@X,U@a]=-2U@X;
Br[U@X,U@z]=0;
Br[U@X,U@y]=0;
Br[U@X,U@x]=(s-1)U[];
Br[U@Y,U@Z]=0;
Br[U@Y,U@b]=-2U@Y;
Br[U@Y,U@a]=U@Y;
Br[U@Y,U@z]=0;
Br[U@Y,U@y]=(t-1)U[];
Br[U@Y,U@x]=0;
Br[U@Z,U@b]=-U@Z;
Br[U@Z,U@a]=-U@Z;
Br[U@Z,U@z]=(s t-1)U[];
Br[U@Z,U@y]=-U@X;
Br[U@Z,U@x]=s U@Y;
Br[U@b,U@a]=0;
Br[U@b,U@z]=-U@z;
Br[U@b,U@y]=-2U@y;
Br[U@b,U@x]=U@x;
Br[U@a,U@z]=-U@z;
Br[U@a,U@y]=U@y;
Br[U@a,U@x]=-2U@x;
Br[U@z,U@y]=0;
Br[U@z,U@x]=0;
Br[U@y,U@x]=-U@z;

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

(Subscript[U, i_])[ℰ_] := ℰ /. {A->(Subscript[A, i]),s->(Subscript[s, i]),B->(Subscript[B, i]),t->(Subscript[t, i]), u_U :> Replace[u, x_ :> (Subscript[x, i]),1]};
Br[U[(Subscript[(x_), i_])],U[(Subscript[(y_), i_])]]:=Br[U[(Subscript[x, i])],U[(Subscript[y, i])]]=(Subscript[U, i])[Br[U@x,U@y]];
Br[U[(Subscript[(x_), i_])],U[(Subscript[(y_), j_])]] /; i=!=j := 0;
Br[x_,x_]=0;
Br[U[y_],U[x_]]:=Br[U[y],U[x]]=Simp[-Br[U[x],U[y]]];
Br[x_,y_] := x**y-y**x;

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[xx___,x_] ** U[y_,yy___] := If[x⪯y,U[xx,x,y,yy], U@xx**(U@y**U@x+Br[U@x,U@y])**U@yy];

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

UProducts[{},0]={UU[]};
UProducts[{},n_Integer] /; n>0 = {};
UProducts[{x_,xs___}, n_Integer] := Sort@Flatten@Table[UU[(x^k)]**u, {k,0,n},{u,UProducts[{xs},n-k]}];
UProducts[xs_List, k_Integer, n_Integer] := UProducts[Flatten@Table[(Subscript[x, j]), {x,xs}, {j,k}], n];
UProducts[any__, {n_}] := Flatten@Table[UProducts[any,k], {k,0,n}];

Δ[i_,j_,k_][ℰ_] := Simp[ℰ/. {
w_.U[]:>(w /. {(Subscript[A, i])->(Subscript[A, j])+(Subscript[A, k]),(Subscript[B, i])->(Subscript[B, j])+(Subscript[B, k]),(Subscript[s, i])->(Subscript[s, j])(Subscript[s, k]),(Subscript[t, i])->(Subscript[t, j])(Subscript[t, k])})U[],
w_.v_U :> (w /. {(Subscript[A, i])->(Subscript[A, j])+(Subscript[A, k]),(Subscript[B, i])->(Subscript[B, j])+(Subscript[B, k]),(Subscript[s, i])->(Subscript[s, j])(Subscript[s, k]),(Subscript[t, i])->(Subscript[t, j])(Subscript[t, k])})NonCommutativeMultiply@@(v /. {
(Subscript[X, i])->U@(Subscript[X, j])(Subscript[s, k])+U@(Subscript[X, k]),
(Subscript[Y, i])->U@(Subscript[Y, j])(Subscript[t, k])+U@(Subscript[Y, k]),
(Subscript[Z, i])->U@(Subscript[Z, j])(Subscript[s, k])(Subscript[t, k])+U@(Subscript[Z, k])+(Subscript[s, k])UU[(Subscript[X, j]),(Subscript[Y, k])]
(Subscript[b, i])->U@(Subscript[b, j])+U@(Subscript[b, k]), 
(Subscript[a, i])->U@(Subscript[a, j])+U@(Subscript[a, k]),
(Subscript[z, i])->U@(Subscript[z, j])+U@(Subscript[z, k]),
(Subscript[y, i])->U@(Subscript[y, j])+U@(Subscript[y, k]),
(Subscript[x, i])->U@(Subscript[x, j])+U@(Subscript[x, k]),
(Subscript[u_, l_]):>U@(Subscript[u, l])

})
}]

S[i_][ℰ_] := Simp[ℰ /. {z_.x_U:>(z /. {(Subscript[A, i])->-(Subscript[A, i]),(Subscript[B, i])->-(Subscript[B, i]),(Subscript[s, i])->((Subscript[s, i])^(-1)),(Subscript[t, i])->((Subscript[t, i])^(-1))})S[i][x]}];
S[i_][U[]]=U[];
S[i_][U[(Subscript[w_, j_]),more___]] /; i≠j := U[(Subscript[w, j])]**S[i][U[more]];   (*Careful! if mathematica cannot decide i==j or not then we get an error*)
S[i_][U[(Subscript[X, i_]),more___]] := S[i][U[more]]**(-((Subscript[s, i])^(-1))U@(Subscript[X, i]));
S[i_][U[(Subscript[Y, i_]),more___]] := S[i][U[more]]**(-((Subscript[t, i])^(-1))U@(Subscript[Y, i]));
S[i_][U[(Subscript[Z, i_]),more___]] := S[i][U[more]]**(-((Subscript[t, i])^(-1))((Subscript[s, i])^(-1))U@(Subscript[Z, i])+U[X,Y]((Subscript[t, i])^(-1))((Subscript[s, i])^(-1)));
S[i_][U[(Subscript[b, i_]),more___]] := S[i][U[more]]**(-U@(Subscript[b, i]));
S[i_][U[(Subscript[a, i_]),more___]] := S[i][U[more]]**(-U@(Subscript[a, i]));
S[i_][U[(Subscript[z, i_]),more___]] := S[i][U[more]]**(-U@(Subscript[z, i]));
S[i_][U[(Subscript[y, i_]),more___]] := S[i][U[more]]**(-U@(Subscript[y, i]));
S[i_][U[(Subscript[x, i_]),more___]] := S[i][U[more]]**(-U@(Subscript[x, i]));

σ[i_,j_][ℰ_] := ℰ /. {i->k,j->i}/.k->j;

mul[i_,j_][ℰ_] := Simp[ℰ /. x_U :> DeleteCases[x,(Subscript[_, j])]**U@@Cases[x,(Subscript[y_, j]):>(Subscript[y, i])] /. {(Subscript[A, j])->(Subscript[A, i]),(Subscript[B, j])->(Subscript[B, i]),(Subscript[s, j])->(Subscript[s, i]), (Subscript[t, j])->(Subscript[t, i])}];
mul[i_,j_,k_][ℰ_] := ℰ // mul[i,j] // σ[i,k];

CoUnit[i_][ℰ_] :=Simp[ℰ/. {z_.x_U:>(z/. {t->1,b->0,(Subscript[b, i])->0,(Subscript[t, i])->1})CoUnit[i][x]}] ;
CoUnit[i_][U[]]=U[];
CoUnit[i_][U[(Subscript[y_, j_]),more___]] /; i≠j := U[(Subscript[y, j])]**CoUnit[i][U[more]];
CoUnit[i_][U[(Subscript[y_, i_]),more___]] :=0;

ToDegree[n_][ℰ_] := (Simp[ℰ] /. { (Subscript[A, i_]):>ℏ (Subscript[A, i]),(Subscript[B, i_]):>ℏ (Subscript[B, i]), (Subscript[s, i_]):>(E^(ℏ (Subscript[A, i]))) ,(Subscript[t, i_]):>(E^(ℏ (Subscript[B, i]))),A:>ℏ A,B:>ℏ B, s:>(E^(ℏ A)) ,t:>(E^(ℏ B)),w_U:>(ℏ^(Count[w,X|(Subscript[X, _])]+Count[w,Y|(Subscript[Y, _])]+Count[w,Z|(Subscript[Z, _])]))w} /. v_.w_U :>Normal[Series[v,{ℏ,0,n}]]*w)/.ℏ->1

Check anti-symmetry and Jacobi and associativity.

bas=UProducts[PBWBasis,1,{3}];
Table[Br[c,d]+Br[d,c]//Simp, {c,bas},{d,bas}] //Flatten//Union

bas=UProducts[Take[PBWBasis,5],1,{3}];
Table[
{c,d,e}=cde;
Simp[Br[Br[c,d],e]+Br[Br[d,e],c]+Br[Br[e,c],d]],
{cde, Subsets[bas,{3}]}
] //Flatten//Union

bas=UProducts[Take[PBWBasis,4],1,{3}];
Table[
{c,d,e}=cde;
Simp[c**(d**e)-(c**d)**e],
{cde, Subsets[bas,{3}]}
] //Flatten//Union

Check co-associativity

Table[c,{c,bas}]

bas=UProducts[PBWBasis,1,{1}];
Table[Δ[1,4,3][c]//Simp,{c,bas}]

bas=UProducts[PBWBasis,1,{1}];
Table[Δ[4,1,2][Δ[1,4,3][c]]-
Δ[4,2,3][Δ[1,1,4][c]]//Simp,{c,bas}]//Union

S-Delta-axiom

bas=UProducts[PBWBasis,1,{1}];
Table[mul[2,3,1][S[2][Δ[1,2,3][c]]]//Simp,{c,bas}]//Union

Sum[F[i,j],{i,0,3},{j,0,3-i}]

R[i_,j_,d_]:=Sum[((((Subscript[A, i])^(Subscript[n, 4]))((Subscript[B, i])^(Subscript[n, 5])))/((Subscript[n, 1])!(Subscript[n, 2])!(Subscript[n, 3])!(Subscript[n, 4])!(Subscript[n, 5])!))UU[((Subscript[X, i])^(Subscript[n, 1])),((Subscript[Y, i])^(Subscript[n, 2])),((Subscript[Z, i])^(Subscript[n, 3])),((Subscript[b, j])^(Subscript[n, 5])),((Subscript[a, j])^(Subscript[n, 4])),((Subscript[z, j])^(Subscript[n, 3])),((Subscript[y, j])^(Subscript[n, 2])),((Subscript[x, j])^(Subscript[n, 1]))],{(Subscript[n, 1]),0,d},{(Subscript[n, 2]),0,d-(Subscript[n, 1])},{(Subscript[n, 3]),0,d-(Subscript[n, 1])-(Subscript[n, 2])},{(Subscript[n, 4]),0,d-(Subscript[n, 1])-(Subscript[n, 2])-(Subscript[n, 3])},{(Subscript[n, 5]),0,d-(Subscript[n, 1])-(Subscript[n, 2])-(Subscript[n, 3])-(Subscript[n, 4])}]//ToDegree[d]

R[1,2,2]

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

R3[2]//ToDegree[1]

R3[3]//ToDegree[2]