Pensieve header: Implementing ordering symbols for U(g0).

Reminders

Implementing (Subscript[g, 0])

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

$TD=3;
ℏ /: (ℏ^(d_. ))/;d>$TD :=0;

(ℏ^(d_. ))/;d>$TD :=0;

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

(Subscript[U, i_])[ℰ_] := ℰ /. {h->(Subscript[h, i]),t->(Subscript[t, i]), u_U :> Replace[u, x_ :> (Subscript[x, i]),1]};
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_,x_]=0;
B[U[y_],U[x_]]:=B[U[y],U[x]]=Simp[-B[U[x],U[y]]];
B[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+B[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}];

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

UExp[u_]:=Module[{s,t,k},
s=t=U[]; k=0;
While[k<20∧0=!=(t=t**u), s+=t/(++k)!];
Simp[s]
];
(Subscript[R, i_,j_]):=UExp[(Subscript[r, i,j])];

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

UExp[ℏ U[(Subscript[e, 1])]]

$TD=5; UExp[ℏ U[(Subscript[e, 1])]]

$TD=3; Simp[(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])-(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])]

$TD=4; Simp[(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])-(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])]

(Subscript[R, 1,2])

old above / new below

The “Internal Multiplication” and Meta-Associativity

Join[f[a,b],f[b,c]]

?Cases

Cases[{(Subscript[a, 1]),(Subscript[b, 2]),(Subscript[c, 1])}, (Subscript[x_, 1])]

Cases[{(Subscript[a, 1]),(Subscript[b, 2]),(Subscript[c, 1])}, (Subscript[x_, 1]):>f[x]]

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[2,1,1]//m[1,3,1])-(u//m[2,3,2]//m[1,2,1]),
{u,UProducts[{e,l,f},4,{3}]}
]//Short

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

$TD=2;(Subscript[R, 4,1])**(Subscript[R, 2,5])**(Subscript[R, 6,3])

$TD=2; (Subscript[R, 4,1])**(Subscript[R, 2,5])**(Subscript[R, 6,3]) // m[1,2,1]//m[1,3,1]//m[1,4,1]//m[1,5,1]//m[1,6,1]

Timing[$TD=3; (Subscript[R, 4,1])**(Subscript[R, 2,5])**(Subscript[R, 6,3]) // m[1,2,1]//m[1,3,1]//m[1,4,1]//m[1,5,1]//m[1,6,1]]

Timing[$TD=4; (Subscript[R, 4,1])**(Subscript[R, 2,5])**(Subscript[R, 6,3]) // m[1,2,1]//m[1,3,1]//m[1,4,1]//m[1,5,1]//m[1,6,1] // Short]

Ordering Symbols

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

Theorem. .
Brute Proof.

$TD=6;𝕆[Exp[ℏ (Subscript[h, 1])(Subscript[l, 2])+(((E^(ℏ (Subscript[h, 1])))-1)/(Subscript[h, 1]))(Subscript[e, 1])(Subscript[f, 2])], {(Subscript[e, 1])}->1,{(Subscript[l, 2]),(Subscript[f, 2])}->2]==(Subscript[R, 1,2])

Timing[$TD=3;𝕆[Exp[ℏ h (Subscript[l, 1])+(((E^(ℏ h))-1)/h)(Subscript[e, 4])(Subscript[f, 1])+ℏ h (Subscript[l, 5])+(((E^(ℏ h))-1)/h)(Subscript[e, 2])(Subscript[f, 5])+ℏ h (Subscript[l, 3])+(((E^(ℏ h))-1)/h)(Subscript[e, 6])(Subscript[f, 3])], {(Subscript[l, 1]),(Subscript[f, 1]),(Subscript[e, 2]),(Subscript[l, 3]),(Subscript[f, 3]),(Subscript[e, 4]),(Subscript[l, 5]),(Subscript[f, 5]),(Subscript[e, 6])}->1] /. (Subscript[h, 1])->h]

Timing[$TD=6;𝕆[Exp[ℏ h (Subscript[l, 1])+(((E^(ℏ h))-1)/h)(Subscript[e, 4])(Subscript[f, 1])+ℏ h (Subscript[l, 5])+(((E^(ℏ h))-1)/h)(Subscript[e, 2])(Subscript[f, 5])+ℏ h (Subscript[l, 3])+(((E^(ℏ h))-1)/h)(Subscript[e, 6])(Subscript[f, 3])], {(Subscript[l, 1]),(Subscript[f, 1]),(Subscript[e, 2]),(Subscript[l, 3]),(Subscript[f, 3]),(Subscript[e, 4]),(Subscript[l, 5]),(Subscript[f, 5]),(Subscript[e, 6])}->1] /. (Subscript[h, 1])->h]

The Big (Subscript[g, 0]) Lemma.
1. 𝕆((e^(γl+βe))|le)=𝕆((e^(γl+(e^γ)βe))|el).
2. 𝕆((e^(γl+βf))|fe)=𝕆((e^(γl+(e^γ)βf))|lf).
3. 𝕆((e^(βe+αf+δef))|fe)=𝕆(((νe)^(ν(-αβh+βe+αf+δef)))|ef).

Brute Proof.

$TD=3; 𝕆[(E^(ℏ γ (Subscript[l, 1])+β ℏ (Subscript[e, 1]))),{(Subscript[l, 1]),(Subscript[e, 1])}->1]

$TD=3; 𝕆[(E^(ℏ γ (Subscript[l, 1])+(E^(ℏ γ))β ℏ (Subscript[e, 1]))),{(Subscript[e, 1]),(Subscript[l, 1])}->1]

$TD=6; 𝕆[(E^(ℏ γ (Subscript[l, 1])+β ℏ (Subscript[e, 1]))),{(Subscript[l, 1]),(Subscript[e, 1])}->1]==𝕆[(E^(ℏ γ (Subscript[l, 1])+(E^(ℏ γ))β ℏ (Subscript[e, 1]))),{(Subscript[e, 1]),(Subscript[l, 1])}->1]

$TD=6; 𝕆[(E^(ℏ γ (Subscript[l, 1])+β ℏ (Subscript[f, 1]))),{(Subscript[f, 1]),(Subscript[l, 1])}->1]==𝕆[(E^(ℏ γ (Subscript[l, 1])+(E^(ℏ γ))β ℏ (Subscript[f, 1]))),{(Subscript[l, 1]),(Subscript[f, 1])}->1]

$TD=3; 𝕆[(E^(ℏ(β (Subscript[e, 1])+α (Subscript[f, 1])+δ (Subscript[e, 1])(Subscript[f, 1])))),{(Subscript[f, 1]),(Subscript[e, 1])}->1]

$TD=6; With[{ν=(((1+ℏ h δ))^(-1))}, 
𝕆[(E^(ℏ(β (Subscript[e, 1])+α (Subscript[f, 1])+δ (Subscript[e, 1])(Subscript[f, 1])))),{(Subscript[f, 1]),(Subscript[e, 1])}->1] == 𝕆[ν (E^(ℏ ν(-ℏ h α β+ β (Subscript[e, 1])+α (Subscript[f, 1])+δ (Subscript[e, 1])(Subscript[f, 1])))),{(Subscript[e, 1]),(Subscript[f, 1])}->1]  /. (Subscript[h, 1])->h
]