Pensieve header: Implementing U(g0).

Implementing (Subscript[g, 0])

PBWRule={e->1,l->2,f->3};
B[U@l,U@e]=-(B[U@e,U@l]=U@e);
B[U@f,U@l]=-(B[U@l,U@f]=U@f);
B[U@e,U@f]=-(B[U@f,U@e]=h U[]);

(Subscript[U, i_])[ℰ_] := ℰ /. {h->(Subscript[h, 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_])]]:=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}/.PBWRule]; x_≺y_:=!OrderedQ[{y,x}/.PBWRule];
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_] := If[x≺y, U[x,y], U[y,x]+B[U@x,U@y]];
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**(U@xn**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];

Testing (Subscript[g, 0])

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}];

B[U@(Subscript[f, 1]),U@(Subscript[e, 1])]

UProducts[{e,l,f},2,{3}]

bas=UProducts[{e,l,f},2,{3}];
Table[B[x,y]+B[y,x], {x,bas},{y,bas}] //Flatten//Union

bas=UProducts[{e,l,f},2,{2}];
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

bas=UProducts[{e,l,f},2,{2}];
Table[
{x,y,z}=xyz;
Simp[x**(y**z)-(x**y)**z],
{xyz, Subsets[bas,{3}]}
] //Flatten//Union

Testing CYBE

(Subscript[r, i_,j_]):=(Subscript[h, i])UU[(Subscript[l, j])]+UU[(Subscript[f, i]),(Subscript[e, j])]

B[(Subscript[r, 1,2]),(Subscript[r, 1,3])]

B[(Subscript[r, 1,3]),(Subscript[r, 2,3])]

B[(Subscript[r, 1,2]),(Subscript[r, 2,3])]

B[(Subscript[r, 1,2]),(Subscript[r, 1,3])]+B[(Subscript[r, 1,3]),(Subscript[r, 2,3])]+B[(Subscript[r, 1,2]),(Subscript[r, 2,3])]

Testing YBE

UExp[n_Integer,u_]:=Module[{t},
t=U[];
Simp[t+Sum[((t=t**u)/(k!)), {k,n}]]
];
(Subscript[R, i_,j_])[n_]:=UExp[n,(Subscript[r, i,j])];

UExp[5,U@(Subscript[e, 1])]

(Subscript[R, 1,2])[4]

With[{n=2},Simp[(Subscript[R, 1,2])[n]**(Subscript[R, 1,3])[n]**(Subscript[R, 2,3])[n]-(Subscript[R, 2,3])[n]**(Subscript[R, 1,3])[n]**(Subscript[R, 1,2])[n]]] // Short

ToDegree[n_][ℰ_] := Simp[ℰ/.{(Subscript[h, i_]):>ℏ (Subscript[h, i]), u_U:>(ℏ^(Count[u,(Subscript[f, _])]))u}] /. a_.x_U :>Normal[Series[a,{ℏ,0,n}]]*x /. ℏ->1

With[{n=2},Simp[(Subscript[R, 1,2])[n]**(Subscript[R, 1,3])[n]**(Subscript[R, 2,3])[n]-(Subscript[R, 2,3])[n]**(Subscript[R, 1,3])[n]**(Subscript[R, 1,2])[n]] // ToDegree[n+2]]

With[{n=3},Simp[(Subscript[R, 1,2])[n]**(Subscript[R, 1,3])[n]**(Subscript[R, 2,3])[n]-(Subscript[R, 2,3])[n]**(Subscript[R, 1,3])[n]**(Subscript[R, 1,2])[n]] // ToDegree[n]]

The “Internal Multiplication” and Meta-Associativity

m[i_,j_,k_][ℰ_] := Simp[ℰ /. {
u_U :> UU@@Join[DeleteCases[u,(Subscript[x_, i|j])],U@@Cases[u,(Subscript[x_, i]):>(Subscript[x, k])],U@@Cases[u,(Subscript[x_, j]):>(Subscript[x, k])]],
(Subscript[h, i|j])->(Subscript[h, k])
}]

UU[(Subscript[e, 1]),(Subscript[l, 4]),(Subscript[f, 2])]

UU[(Subscript[e, 1]),(Subscript[l, 4]),(Subscript[f, 2])]//m[1,2,3]

UU[(Subscript[e, 1]),(Subscript[l, 4]),(Subscript[f, 2])]//m[2,1,3]

Union@Table[
(u//m[1,2,1]//m[1,3,1])-(u//m[2,3,2]//m[1,2,1]),
{u,UProducts[{e,l,f},4,{3}]}
]

The Invariant of the Trefoil

With[{n=2},(Subscript[R, 4,1])[n]**(Subscript[R, 2,5])[n]**(Subscript[R, 6,3])[n] // ToDegree[n]]

With[{n=2},(Subscript[R, 4,1])[n]**(Subscript[R, 2,5])[n]**(Subscript[R, 6,3])[n] // ToDegree[n] // m[1,2,1]//m[1,3,1]//m[1,4,1]//m[1,5,1]//m[1,6,1]]

With[{n=3},(Subscript[R, 4,1])[n]**(Subscript[R, 2,5])[n]**(Subscript[R, 6,3])[n] // ToDegree[n] // m[1,2,1]//m[1,3,1]//m[1,4,1]//m[1,5,1]//m[1,6,1]]

Ordering Symbols

𝕆[n_, poly_, specs___] := Module[{vs,us},
vs=Join@@(First /@ {specs});
us=Join@@({specs} /. (l_->s_) :> (l/.(Subscript[x_, i_]):>(Subscript[x, s])));
Total[CoefficientRules[Normal@Series[poly, {ℏ,0,n}], vs] /. (p_->c_) :> c UU@@((us^p))]]