Pensieve header: Figuring out the double of the 2D pencil; older versions under “MetaDouble-*”.

Issues:
1. Improve DUForm.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2017-06"];

The “degree carrier” is ℏ, and all “coupling constants” are proportional to it.

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

The 2D Lie BiAlgebra Pencil

We hope to stick to A=(e^(ℏ β a)) and to B=(e^(ℏ α b)), where [a,x]=α x and [b,y]=-β y.
Also, (Subscript[Δ, 12])(a,A,x,b,B,y) = ((Subscript[a, 1])+(Subscript[a, 2]), (Subscript[A, 1])(Subscript[A, 2]), (Subscript[x, 1])+(Subscript[A, 1])(Subscript[x, 2]), (Subscript[b, 1])+(Subscript[b, 2]), (Subscript[B, 1])(Subscript[B, 2]), (Subscript[y, 1])(Subscript[B, 2])+(Subscript[y, 2])).
Also, (a,x) and ℏ(b,y) are dual bases.

AlgebraAtom = a|A[_]|x|b|B[_]|y;
$PBWRule={A[_]->1,a->2,x->3,y->4,B[_]->5,b->6};

B[a,x] = α x; B[x,A[n_]]=((E^(n ℏ α β))-1)U[A[n],x]; B[a,A[_]]=0;
B[y,b] = β y; B[B[n_],y]=((E^(n ℏ α β))-1)U[y,B[n]]; B[b,B[_]]=0;
Δ[a]=(Subscript[U, 1])[a](Subscript[U, 2])[]+(Subscript[U, 1])[](Subscript[U, 2])[a]; Δ[A[n_]]:=(Subscript[U, 1])[A[n]](Subscript[U, 2])[A[n]]; Δ[x]=(Subscript[U, 1])[x](Subscript[U, 2])[]+(Subscript[U, 1])[A[1]](Subscript[U, 2])[x];
Δ[b]=(Subscript[U, 1])[b](Subscript[U, 2])[]+(Subscript[U, 1])[](Subscript[U, 2])[b]; Δ[B[n_]]:=(Subscript[U, 1])[B[n]](Subscript[U, 2])[B[n]]; Δ[y]=(Subscript[U, 1])[y](Subscript[U, 2])[B[1]]+(Subscript[U, 1])[](Subscript[U, 2])[y];
S[a]=-a; S[A[n_]]:=A[-n]; S[x] = - U[A[-1],x];
S[b]=-b; S[B[n_]]:=B[-n]; S[y] = - U[y,B[-1]];
Si[a]=-a; Si[A[n_]]:=A[-n]; Si[x] = - U[x,A[-1]];
Si[b]=-b; Si[B[n_]]:=B[-n]; Si[y] = - U[B[-1],y];
(* This extra line is annoying *)

ExpandAB[ℰ_] := Expand@Normal@Series[ℰ //. {
c_. (Subscript[U, i_])[λ___, A[n_],ρ___] :> Expand[c Sum[(((((-1))^d)(ℏ^d)(β^d)(n^d))/(d!))(Subscript[U, i])[λ,Sequence@@Table[a,{d}],ρ],{d,0,$TD}]],
c_. (Subscript[U, i_])[λ___, B[n_],ρ___] :> Expand[c Sum[(((((-1))^d)(ℏ^d)(α^d)(n^d))/(d!))(Subscript[U, i])[λ,Sequence@@Table[b,{d}],ρ],{d,0,$TD}]]
}, {ℏ,0,$TD}]

UEA with provisional modification

This section is based on penseive://Projects/UEA/.

B[0,_]=0; B[_,0]=0;
B[c_*x:AlgebraAtom,y_]:=Expand[c B[x,y]];
B[y_,c_*x:AlgebraAtom]:=Expand[c B[y,x]];
B[x_Plus,y_] := B[#,y]& /@ x;
B[x_,y_Plus] := B[x,#]& /@ y;
B[x_,x_] =0;
B[y_,x_] := Expand[-B[x,y]];

x_⪯y_:=OrderedQ[{x,y}/.$PBWRule]; x_≺y_:=!OrderedQ[{y,x}/.$PBWRule];
(Subscript[UU, i_])[] := (Subscript[U, i])[]; (Subscript[UU, i_])[1] := (Subscript[U, i])[];
(Subscript[UU, i_])[((x_[n_])^(p_))] := (Subscript[U, i])[x[n p]];
(Subscript[UU, i_])[((x_)^(p_))]:=(Subscript[UU, i])@@Table[x,{p}];
(Subscript[UU, i_])[ℰ_] := ℰ /. {
U[xs__] :> (Subscript[UU, i])[xs],
x:AlgebraAtom:>(Subscript[U, i])[x]
};
(Subscript[UU, i_])[x_,xs__] := (Subscript[UU, t1])[x](Subscript[UU, t2])[xs] // Expand // (Subscript[m, t1,t2->i]);
USimp[ℰ_]:= Collect[ℰ, Times[(Subscript[U, _])[__]..], Expand];
USimp[ℰ_]:=Expand[ℰ];

(Subscript[m, s__])[0]=0;
(Subscript[m, s__])[x_Plus] := (Subscript[m, s])/@x;
(Subscript[m, i_->j_])[ℰ_] := ℰ /. (Subscript[U, i])->(Subscript[U, j]);

(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[x___](Subscript[U, j_])[]]:=c (Subscript[U, k])[x];
(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[](Subscript[U, j_])[y___]]:=c (Subscript[U, k])[y];
(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[xx___,x_[n1_]](Subscript[U, j_])[x_[n2_],yy___]]:= USimp[c If[TrueQ[n1+n2==0], (Subscript[U, i])[xx](Subscript[U, j])[yy], (Subscript[U, i])[xx,x[n1+n2]](Subscript[U, j])[yy]] // (Subscript[m, i,j->k])];
(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[xx___,x_](Subscript[U, j_])[y_,yy___]]:=If[x⪯y,
c (Subscript[U, k])[xx,x,y,yy],
(((Subscript[U, i])[xx]((Subscript[U, j])[y,x]+(Subscript[UU, j])[B[x,y]]) // Expand // (Subscript[m, i,j->i]))(Subscript[U, j])[yy] // Expand // (Subscript[m, i,j->k]))c // USimp
];

Supp[ℰ_]:= Union@Cases[{ℰ}, (Subscript[U, i_])[___]:>i, ∞];

Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
x_**y_ := Module[
{Sx=Supp[x], Sy=Supp[y],is,σ,z},
If[MatchQ[Sx⋃Sy,{_Integer...}]&&Min[Sx⋃Sy]<0,
is=Abs[Sx]⋂Abs[Sy];
z=x; Do[z=(Subscript[m, -i->-σ@i])[(Subscript[m, i->σ@i])[z]], {i,is}];
z=USimp[y z]; Do[z=(Subscript[dm, σ@i,i->i])[z], {i,is}];
z,
(* else *) is=Sx⋂Sy;
z=x; Do[z=(Subscript[m, i->σ@i])[z], {i,is}];
z=USimp[y z]; Do[z=(Subscript[m, σ@i,i->i])[z], {i,is}];
z
]
];
UB[x_,y_] := USimp[x**y-y**x];

𝕆[func_] := Normal@Series[func,{ℏ,0,$TD}];
𝕆[specs_, func_] := Module[{rules,vars,elems},
rules=Union@@Cases[{specs}, (Subscript[U, _])[u___]:>Cases[{u},r_Rule], ∞];
vars=First/@rules; elems=Last/@rules;
USimp@Total[CoefficientRules[𝕆[func], vars] /. (ps_ -> c_) :> c(
specs /. MapThread[((#1->_) :> ((#3)^(#2)))&,{vars,ps,elems}] /. (Subscript[U, i_]):>(Subscript[UU, i])
)]
]

The 2D Lie BiAlgebra Pencil, Testing

𝕆[(Subscript[U, 1])[a->a], (E^(ℏ β a))]

USimp@With[{An=𝕆[(Subscript[U, 1])[a->a], (E^(-n ℏ β a))]}, UB[(Subscript[U, 1])[x],An]-𝕆[(E^(n ℏ α β))-1]An**(Subscript[U, 1])[x]]

B[x,A[3]]

$TD=6;
USimp@With[{Bn=𝕆[(Subscript[U, 1])[b->b],(E^(-n ℏ α b))]}, UB[Bn,(Subscript[U, 1])[y]]-𝕆[(E^(n ℏ α β))-1](Subscript[U, 1])[y]**Bn]

z=(Subscript[U, 1])[a,A[2],x,x,x](Subscript[U, 2])[a,a,x](Subscript[U, 3])[a,a,A[-3],x];
(z // (Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))-(z // (Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

z=(Subscript[U, 1])[y,y,y,b,B[2]](Subscript[U, 2])[y,b,b](Subscript[U, 3])[y,b,b,B[-3]];
(z// (Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))-(z // (Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

The Co-Product and Co-Associativity

(Subscript[Δ, i_->j_,k_])[ℰ_] := USimp@Module[{tj,tk}, ℰ /. {
(Subscript[U, i])[] -> (Subscript[U, j])[](Subscript[U, k])[],
(Subscript[U, i])[f_,fs___] :> (USimp[(Δ[f]/. {(Subscript[U, 1])->(Subscript[U, j]),(Subscript[U, 2])->(Subscript[U, k])})(Subscript[Δ, i->tj,tk])[(Subscript[U, i])[fs]]]  // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k]))
}];
(Subscript[Δ, i_->j_,k_,l__])[ℰ_] := ℰ // (Subscript[Δ, i->j,k])//(Subscript[Δ, k->k,l])

(Subscript[Δ, 1->1,2])[(Subscript[U, 1])[#]]& /@ {a,A[7],x,y,b,B[-3]}

{lhs=(Subscript[U, 1])[x] // (Subscript[Δ, 1->1,2]) // (Subscript[Δ, 2->2,3]), rhs=(Subscript[U, 1])[x] // (Subscript[Δ, 1->1,3]) // (Subscript[Δ, 1->1,2]), lhs==rhs}

(Subscript[U, 1])[y] // (Subscript[Δ, 1->1,2])

{lhs=(Subscript[U, 1])[y] // (Subscript[Δ, 1->1,2]) // (Subscript[Δ, 2->2,3]), rhs=(Subscript[U, 1])[y] // (Subscript[Δ, 1->1,3]) // (Subscript[Δ, 1->1,2]), lhs==rhs}

z=(Subscript[U, 1])[a,A[2],x,x,x](Subscript[U, 2])[a,a,A[-3],x];
(z // (Subscript[m, 1,2->1]) // (Subscript[Δ, 1->1,2]))-(z//(Subscript[Δ, 2->3,4])//(Subscript[Δ, 1->1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))

z=(Subscript[U, 1])[y,y,y,b,B[2]](Subscript[U, 2])[y,b,b,B[-3]];
(z// (Subscript[m, 1,2->1]) // (Subscript[Δ, 1->1,2]))-(z//(Subscript[Δ, 2->3,4])//(Subscript[Δ, 1->1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))

The Antipode

(Subscript[S, i_])[ℰ_] := Module[{ti}, USimp[
ℰ /. (Subscript[U, i])[x_,xs___] :> (Subscript[m, ti,i->i])[Expand[(Subscript[UU, i])[S[x]](Subscript[S, ti])[(Subscript[U, ti])[xs]]]]
]];
(Subscript[Si, i_])[ℰ_] := Module[{ti}, USimp[
ℰ /. (Subscript[U, i])[x_,xs___] :> (Subscript[m, ti,i->i])[Expand[(Subscript[UU, i])[Si[x]](Subscript[Si, ti])[(Subscript[U, ti])[xs]]]]
]];

{(Subscript[U, 1])[x] // (Subscript[S, 1]) // (Subscript[S, 1]), (Subscript[U, 1])[y] // (Subscript[S, 1]) // (Subscript[S, 1])}

{(Subscript[U, 1])[x] // (Subscript[S, 1]) // (Subscript[Si, 1]), (Subscript[U, 1])[y] // (Subscript[S, 1]) // (Subscript[Si, 1])}

{z=(Subscript[U, 1])[]; (z//(Subscript[Δ, 1->1,2])//(Subscript[S, 1])//(Subscript[m, 1,2->1])), z=(Subscript[U, 1])[]; (z//(Subscript[Δ, 1->1,2])//(Subscript[S, 2])//(Subscript[m, 1,2->1]))}

z=(Subscript[U, 1])[a,A[3],x,x];
{z // (Subscript[Δ, 1->1,2]) // (Subscript[S, 2]) // (Subscript[m, 1,2->1]),  z // (Subscript[Δ, 1->1,2]) // (Subscript[S, 1]) // (Subscript[m, 1,2->1])}

z=(Subscript[U, 1])[y,y,y,b,B[-3]];
{z // (Subscript[Δ, 1->1,2]) // (Subscript[S, 2]) // (Subscript[m, 1,2->1]), z // (Subscript[Δ, 1->1,2]) // (Subscript[S, 1]) // (Subscript[m, 1,2->1])}

{z=(Subscript[U, 1])[a,A[2],x,x,x](Subscript[U, 2])[a,a,A[-3],x]; (z//(Subscript[m, 1,2->1])//(Subscript[S, 1]))-(z//(Subscript[S, 1])//(Subscript[S, 2])//(Subscript[m, 2,1->1])),
z=(Subscript[U, 1])[y,y,y,b,B[2]](Subscript[U, 2])[y,b,b,b,B[6]]; (z//(Subscript[m, 1,2->1])//(Subscript[S, 1]))-(z//(Subscript[S, 1])//(Subscript[S, 2])//(Subscript[m, 2,1->1]))}

{z=(Subscript[U, 1])[a,A[2],x,x,x]; (z//(Subscript[S, 1]) //(Subscript[Δ, 1->2,1]))-(z//(Subscript[Δ, 1->1,2])//(Subscript[S, 1])//(Subscript[S, 2])),
z=(Subscript[U, 1])[y,y,y,b,B[2]]; (z//(Subscript[S, 1]) //(Subscript[Δ, 1->2,1]))-(z//(Subscript[Δ, 1->1,2])//(Subscript[S, 1])//(Subscript[S, 2]))
}

The Pairing

P[U[], U[B[_]]] = P[U[A[_]],U[]] = 1;
P[U[], U[__]] = P[U[__],U[]] = 0;
(({{P[U[a],U[b]]=(ℏ^(-1)), P[U[a],U[B[n_]]]=-n α, P[U[a],U[y]]=0}, {P[U[A[n_]],U[b]]=-n β, P[U[A[n_]],U[B[m_]]]=(E^(n m ℏ α β )), P[U[A[_]],U[y]]=0}, {P[U[x],U[b]]=0, P[U[x],U[B[_]]]=0, P[U[x],U[y]]=(ℏ^(-1))}}));

P[U[],U[]] = 1;
(Subscript[P, i_,j_])[ℰ_] := USimp[ℰ /. (Subscript[U, i])[xs___](Subscript[U, j])[ys___] -> P[U[xs],U[ys]]];

The pairing sequence: ⟨one,one⟩ (above), ⟨many,one⟩, ⟨many,many⟩.

P[U[x_,xs__], U[y_]] := P[U[x,xs],U[y]] = Module[{i,j,k,l}, USimp[(Subscript[U, i])[x](Subscript[UU, j])[xs](Subscript[Δ, k->k,l])[(Subscript[U, k])[y]]] // (Subscript[P, i,k]) // (Subscript[P, j,l])];
P[U[xs__],U[y_,ys__]] := P[U[xs],U[y,ys]] = Module[{i,j,k,l}, USimp[(Subscript[Δ, i->i,j])[(Subscript[UU, i])[xs]](Subscript[U, k])[y](Subscript[UU, l])[ys]] // (Subscript[P, i,k]) // (Subscript[P, j,l])];

z=(Subscript[U, i])[a](Subscript[U, j])[x](Subscript[U, k])[y];
{(Subscript[m, i,j->i])[z]-(Subscript[m, j,i->i])[z], (Subscript[Δ, k->k,l])[z]-(Subscript[Δ, k->l,k])[z]}

Table[z=(Subscript[U, i])[xi](Subscript[U, j])[xj](Subscript[U, k])[yk];
{((Subscript[m, i,j->i])[z]-(Subscript[m, j,i->i])[z])//(Subscript[P, i,k]), ((Subscript[Δ, k->k,l])[z]-(Subscript[Δ, k->l,k])[z]) // (Subscript[P, i,k])//(Subscript[P, j,l])},
{xi,{a,x}}, {xj,{a,x}}, {yk,{b,y}}]

Table[z=(Subscript[U, i])[xi](Subscript[U, k])[yk](Subscript[U, l])[yl];
{((Subscript[Δ, i->i,j])[z]-(Subscript[Δ, i->j,i])[z])//(Subscript[P, i,k])//(Subscript[P, j,l]), ((Subscript[m, k,l->k])[z]-(Subscript[m, l,k->k])[z]) // (Subscript[P, i,k])},
{xi,{a,x}}, {yk,{b,y}}, {yl,{b,y}}]

lhs=Factor@Table[(ℏ^n)P[U@@Table[x,{n}], U@@Table[y,{n}]], {n,$TD=7}]

rhs=Simplify@FunctionExpand@Table[QFactorial[n,(E^(ℏ α β))], {n,$TD=7}]

MapThread[Equal,{lhs,rhs}]

P[U[a,a,a,a,a],U[b,b,b,b,b]]

Table[P[z1,z2],
{z1, {U[], U[a], U[x], U[a,a],U[a,x],U[x,x],U[a,a,a],U[a,a,x],U[a,x,x],U[x,x,x]}}, {z2, {U[], U[b], U[y], U[b,b],U[y,b],U[y,y],U[b,b,b],U[y,b,b],U[y,y,b],U[y,y,y]}}
] // MatrixForm

Pairing axioms:

$TD=5;((Subscript[U, 1])[a,x,x](Subscript[S, -1])[(Subscript[U, -1])[y,y,b]]//Expand//(Subscript[P, 1,-1]))-((Subscript[S, 1])[(Subscript[U, 1])[a,x,x]](Subscript[U, -1])[y,y,b]//Expand//(Subscript[P, 1,-1]))//ExpandAB

(((Subscript[U, 1])[a,x,x](Subscript[U, 2])[a,A[1],x] (Subscript[U, -1])[y,y,y,b,b,b]//(Subscript[m, 1,2->1])//Expand) //(Subscript[P, 1,-1]))-
(((Subscript[U, 1])[a,x,x](Subscript[U, 2])[a,A[1],x] (Subscript[U, -1])[y,y,y,b,b,b]//(Subscript[Δ, -1->-1,-2])//Expand) //(Subscript[P, 1,-1])//(Subscript[P, 2,-2]))

(((Subscript[U, 1])[a,x,x,x,x](Subscript[U, -2])[y,B[1],b] (Subscript[U, -1])[y,y,y,b,b,b]//(Subscript[m, -1,-2->-1])//Expand) //(Subscript[P, 1,-1]))-
(((Subscript[U, 1])[a,x,x,x,x](Subscript[U, -2])[y,B[1],b] (Subscript[U, -1])[y,y,y,b,b,b]//(Subscript[Δ, 1->1,2])//Expand) //(Subscript[P, 1,-1])//(Subscript[P, 2,-2]))

The Double

DUForm[ℰ_] := ℰ //. (Subscript[U, i_])[fs___](Subscript[U, j_])[gs___] /; i+j==0∧j>0 :> (Subscript["DU", j])[fs,gs];
(Subscript[DU, i_])[a]:=(Subscript[U, -i])[](Subscript[U, i])[a]; (Subscript[DU, i_])[A[n_]]:=(Subscript[U, -i])[](Subscript[U, i])[A[n]]; (Subscript[DU, i_])[x]:=(Subscript[U, -i])[](Subscript[U, i])[x];
(Subscript[DU, i_])[y]:=(Subscript[U, -i])[y](Subscript[U, i])[];  (Subscript[DU, i_])[b]:=(Subscript[U, -i])[b](Subscript[U, i])[];   (Subscript[DU, i_])[B[n_]]:=(Subscript[U, -i])[B[n]](Subscript[U, i])[];
(Subscript[DU, i_])[] := (Subscript[U, -i])[](Subscript[U, i])[];

(Subscript[DU, 1]) /@ {a,A[1],x,y,b,B[-1]}

(Subscript[dm, i_,j_->k_])[ℰ_] := Module[{t1,t2,t3,h1,h2,h3},
ℰ //(Subscript[Δ, -j->t1,t2,t3])//(Subscript[S, t3])// (Subscript[Δ, i->h1,h2,h3])//(Subscript[P, h1,t1])//(Subscript[P, h3,t3])//(Subscript[m, j,h2->k])//(Subscript[m, -i,t2->-k])];
(Subscript[dΔ, i_->j_,k_])[ℰ_] := ℰ // (Subscript[Δ, i->j,k])//(Subscript[Δ, -i-> -j,-k]);
(Subscript[dS, i_])[ℰ_] := Module[{h}, (ℰ // (Subscript[m, i->h]) // (Subscript[Si, h]) // (Subscript[S, -i]))(Subscript[U, -h])[](Subscript[U, i])[] // Expand // (Subscript[dm, h,i->i])];

Module[{bas},
bas=Join[{(Subscript[DU, 1])[]},(Subscript[DU, 1]) /@ {a,A[n],x,y,B[m],b}, {β (Subscript[DU, 1])[a]+α (Subscript[DU, 1])[b]}];
Table[If[f**g=!=g**f∨f===(Subscript[DU, 1])[]∨g===(Subscript[DU, 1])[],f**g,"="], {f,bas}, {g,bas}] // ReplacePart[{1,1}->"**"]
] // DUForm // MatrixForm

{(Subscript[DU, 1])[A[1]]**(Subscript[DU, 1])[x], (Subscript[DU, 1])[A[1]]**(Subscript[DU, 1])[y], (Subscript[DU, 1])[x]**(Subscript[DU, 1])[B[1]], (Subscript[DU, 1])[B[1]]**(Subscript[DU, 1])[y]} // DUForm

(Subscript[DU, 1])[x](Subscript[DU, 2])[a] // (Subscript[dm, 1,2->1]) // DUForm

(Subscript[U, -1])[](Subscript[U, 1])[a](Subscript[U, -2])[](Subscript[U, 2])[x] // (Subscript[dm, 1,2->1]) // DUForm

(Subscript[U, -1])[](Subscript[U, 1])[a](Subscript[U, -2])[b](Subscript[U, 2])[] // (Subscript[dm, 1,2->1]) // DUForm

{(Subscript[U, -1])[](Subscript[U, 1])[a](Subscript[U, -2])[y](Subscript[U, 2])[] // (Subscript[dm, 2,1->1]), (Subscript[U, -1])[](Subscript[U, 1])[a](Subscript[U, -2])[y](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])} // DUForm

((Subscript[U, -1])[](Subscript[U, 1])[x](Subscript[U, -2])[b](Subscript[U, 2])[] - (Subscript[U, -1])[b](Subscript[U, 1])[](Subscript[U, -2])[](Subscript[U, 2])[x]) // (Subscript[dm, 1,2->1])//DUForm

(Subscript[U, -1])[](Subscript[U, 1])[A[1]](Subscript[U, -2])[y](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[x](Subscript[U, -2])[b](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[x](Subscript[U, -2])[B[1]](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[DU, 1])[x](Subscript[DU, 2])[y] // (Subscript[dm, 1,2->1])//DUForm

z=(Subscript[U, -1])[](Subscript[U, 1])[x](Subscript[U, -2])[y](Subscript[U, 2])[](Subscript[U, -3])[b](Subscript[U, 3])[];
(z // (Subscript[dm, 1,2->1]) // (Subscript[dm, 1,3->1]))-(z // (Subscript[dm, 2,3->2])//(Subscript[dm, 1,2->1])) // DUForm

$TD=5; z=(Subscript[U, -1])[y,b,b](Subscript[U, 1])[A[2],a,x,x](Subscript[U, -2])[B[-1],y,y,b,b](Subscript[U, 2])[a](Subscript[U, -3])[y,y,b](Subscript[U, 3])[a,a,x,x,x];
(z // (Subscript[dm, 1,2->1]) // (Subscript[dm, 1,3->1]))-(z // (Subscript[dm, 2,3->2])//(Subscript[dm, 1,2->1])) // DUForm

(#->DUForm[(Subscript[dS, 1])[(Subscript[DU, 1])[#]]])& /@ {a,x,y,b}

((Subscript[DU, 1])[x](Subscript[DU, 2])[y] // (Subscript[dm, 1,2->1]) // (Subscript[dS, 1]))-((Subscript[DU, 1])[x](Subscript[DU, 2])[y] // (Subscript[dS, 1])//(Subscript[dS, 2])//(Subscript[dm, 2,1->1])) // ExpandAB

Coassociativity

(lhs=(Subscript[DU, 1])[#] // (Subscript[dΔ, 1->1,2]) // (Subscript[dΔ, 2->2,3]); rhs=(Subscript[DU, 1])[#] // (Subscript[dΔ, 1->1,3]) // (Subscript[dΔ, 1->1,2]); lhs==rhs)& /@ {a,x,y,b}

dΔ is algebra morphism

z=(Subscript[U, -1])[y,y,y,b,B[2]](Subscript[U, 1])[x](Subscript[U, -2])[y,b,b,B[-3]](Subscript[U, 2])[a,x];
(z// (Subscript[dm, 1,2->1]) // (Subscript[dΔ, 1->1,2]))-(z//(Subscript[dΔ, 2->3,4])//(Subscript[dΔ, 1->1,2])//(Subscript[dm, 1,3->1])//(Subscript[dm, 2,4->2]))

dS is algebra anti-morphism

dS is the convolution inverse of dm.

z=(Subscript[U, -1])[y,y,y,b,B[-3]](Subscript[U, 1])[a,x,x];
{z // (Subscript[dΔ, 1->1,2]) // (Subscript[dS, 2]) // (Subscript[dm, 1,2->1]), z // (Subscript[dΔ, 1->1,2]) // (Subscript[dS, 1]) // (Subscript[dm, 1,2->1])}

The R-Matrix

Quesne’s formulas:

q=(E^(ℏ α β)); (Subscript[E, q_])[x_] := Exp[(∑_(k=1)^$TD) ((((1-q))^k)/(k(1-(q^k))))(x^k)];

Table[Together@SeriesCoefficient[(Subscript[E, ρ])[x], {x,0,n}], {n,0,$TD}]

(Subscript[R, i_,j_]) :=𝕆[(Subscript[U, -i])[y->y,b->b](Subscript[U, i])[](Subscript[U, -j])[](Subscript[U, j])[a->a,x->x], (E^(ℏ b a))(Subscript[E, q])[ℏ x y]]

$TD=3; (Subscript[R, 1,2])//DUForm

$TD=5; {lhs=(Subscript[R, 1,3])//(Subscript[dΔ, 1->1,2]), rhs=(Subscript[R, 2,3])**(Subscript[R, 1,3]), lhs-rhs} //Last//ExpandAB// DUForm

$TD=5; {lhs=(Subscript[R, 1,2])//(Subscript[dΔ, 2->2,3]), rhs=(Subscript[R, 1,2])**(Subscript[R, 1,3]), lhs-rhs} //Last //ExpandAB// DUForm

$TD=5; Table[
{lhs=(Subscript[R, 1,2])**(Subscript[dΔ, 1->2,1])[f], rhs=(Subscript[dΔ, 1->1,2])[f]**(Subscript[R, 1,2]), lhs-rhs} //Last //ExpandAB// DUForm,
{f, {(Subscript[U, -1])[](Subscript[U, 1])[a], (Subscript[U, -1])[](Subscript[U, 1])[x],(Subscript[U, -1])[b](Subscript[U, 1])[],(Subscript[U, -1])[y](Subscript[U, 1])[]}}]

$TD=5;{lhs=ExpandAB[(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])], rhs=ExpandAB[(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])], Coefficient[lhs-rhs, (ℏ^$TD)]} // Last

$TD=5; (Subscript[Si, 2])[(Subscript[R, 1,2])]**(Subscript[R, 1,2]) // ExpandAB // DUForm

Cuaps (Unfinished)

Drinfeld element u.

(Subscript[u, i_]):=(Subscript[R, 1,2])//(Subscript[dS, 1])//(Subscript[dm, 2,1->i])

$TD=2;(Subscript[u, 1])//ExpandAB // DUForm

Conjugation by the Drinfeld element implements the square of the antipode.

$TD=3; Table[(Subscript[DU, 1])[f]**(Subscript[u, 1])==(Subscript[u, 1])**(Subscript[dS, 1])[(Subscript[dS, 1])[(Subscript[DU, 1])[f]]]//ExpandAB, {f, {a,x,b,y}}]

Inverse of the Drinfeld element

(Subscript[ui, i_]):=(Subscript[R, 1,2])//(Subscript[dS, 2])//(Subscript[dS, 2])//(Subscript[dm, 2,1->i])

$TD=3;(Subscript[ui, 1])**(Subscript[u, 1])//ExpandAB

Drinfeld commutes with its antipode and the product is central

$TD=3;(Subscript[u, 1])**(Subscript[dS, 1])[(Subscript[u, 1])]-(Subscript[dS, 1])[(Subscript[u, 1])]**(Subscript[u, 1])//ExpandAB

$TD=3;((Subscript[u, 1])**(Subscript[dS, 1])[(Subscript[u, 1])]**(Subscript[DU, 1])[#]-(Subscript[DU, 1])[#]**(Subscript[u, 1])**(Subscript[dS, 1])[(Subscript[u, 1])])&/@{a,x,y,b}//ExpandAB

Multiplying the inverse and antipode of Drinfeld

$TD=3;(Subscript[ui, 1])**(Subscript[dS, 1])[(Subscript[u, 1])]-(Subscript[U, -1])[B[1]](Subscript[U, 1])[A[-1]]//ExpandAB//DUForm

This implies that dS[u] = u (BA^(-1)). In other words, u dS[u] = (u^2)(BA^(-1))so we can take the square root and call it v. This is the ribbon element.

(Subscript[v, i_]):=(𝕆[(Subscript[U, -i])[b->b](Subscript[U, i])[a->a],Exp[(ℏ/2)(-α b+β a)]])**(Subscript[u, i])

$TD=3;(Subscript[u, 1])**(Subscript[dS, 1])[(Subscript[u, 1])]-(Subscript[v, 1])**(Subscript[v, 1])//ExpandAB

v is supposed to be the Reidemeister 1 curl (with the appropriate cuaps/spinners added!). Note how it too is central.

$TD=3;((Subscript[v, 1])**(Subscript[DU, 1])[#]-(Subscript[DU, 1])[#]**(Subscript[v, 1]))&/@{a,x,y,b}//ExpandAB

The rule for the cuaps is to add to a right-moving cup (uv^(-1)) and to a right-moving cap (vu^(-1)). Note how (vu^(-1))= (B^(1/2))(A^(-1/2))

$TD=3;(Subscript[v, 1])**(Subscript[ui, 1])-𝕆[(Subscript[U, -1])[b->b](Subscript[U, 1])[a->a],Exp[(ℏ/2)(-α b+β a)]]//ExpandAB

(Subscript[cap, i_]):=𝕆[(Subscript[U, -i])[b->b](Subscript[U, i])[a->a],Exp[(ℏ/2)(-α b+β a)]]
(Subscript[cup, i_]):=𝕆[(Subscript[U, -i])[b->b](Subscript[U, i])[a->a],Exp[-(ℏ/2)(-α b+β a)]]

Now let’s do R2 and oppositely oriented Reidemeister 2:

$TD=3;(Subscript[dS, 2])[(Subscript[R, 1,2])](Subscript[R, 3,4])//(Subscript[dm, 1,3->1])//(Subscript[dm, 2,4->2])//ExpandAB//DUForm

$TD=3;(Subscript[dS, 2])[(Subscript[R, 1,2])](Subscript[R, 3,4])(Subscript[cup, 5])(Subscript[cap, 6])//(Subscript[dm, 1,3->1])//(Subscript[dm, 4,5->4])//(Subscript[dm, 4,2->4])//(Subscript[dm, 4,6->4])//ExpandAB//DUForm

Rotate a crossing:

$TD=3;((Subscript[cup, 1])(Subscript[dS, 5])[(Subscript[R, 2,5])](Subscript[cap, 3])(Subscript[cup, 4])(Subscript[cap, 6])//(Subscript[dm, 1,2->1])//(Subscript[dm, 1,3->1])//(Subscript[dm, 4,5->4])//(Subscript[dm, 4,6->4]))  -(Subscript[dS, 4])[(Subscript[R, 1,4])]//ExpandAB

Reidemeister 1 curls, the two positives agree with the two negatives and they are inverses and agree with v, (v^(-1)).

$TD=2;{
((Subscript[R, 1,2])(Subscript[cap, 3])//(Subscript[dm, 1,3->1])//(Subscript[dm, 1,2->1]))-((Subscript[R, 1,2])(Subscript[cup, 3])//(Subscript[dm, 2,3->2])//(Subscript[dm, 2,1->1])),
((Subscript[dS, 2])[(Subscript[R, 1,2])](Subscript[cup, 3])//(Subscript[dm, 1,3->1])//(Subscript[dm, 1,2->1]))-((Subscript[dS, 2])[(Subscript[R, 1,2])](Subscript[cap, 3])//(Subscript[dm, 2,3->2])//(Subscript[dm, 2,1->1])),
((Subscript[dS, 2])[(Subscript[R, 1,2])](Subscript[cup, 3])//(Subscript[dm, 1,3->1])//(Subscript[dm, 1,2->1]))**((Subscript[R, 1,2])(Subscript[cap, 3])//(Subscript[dm, 1,3->1])//(Subscript[dm, 1,2->1])),
((Subscript[dS, 2])[(Subscript[R, 1,2])](Subscript[cup, 3])//(Subscript[dm, 1,3->1])//(Subscript[dm, 1,2->1]))-(Subscript[v, 1])}//ExpandAB//DUForm

The Central Element

(Subscript[c, 1])=α (Subscript[U, -1])[b](Subscript[U, 1])[]+β (Subscript[U, -1])[](Subscript[U, 1])[a];
UB[(Subscript[c, 1]),#]& /@ {(Subscript[U, -1])[](Subscript[U, 1])[a],(Subscript[U, -1])[](Subscript[U, 1])[x],(Subscript[U, -1])[y](Subscript[U, 1])[], (Subscript[U, -1])[b](Subscript[U, 1])[]}

Commuting Exponentials

Commuting (e^a) with (e^x):

$TD=5; 𝕆[(Subscript[U, 1])[x->x, a->a], (E^(ℏ(μ x+ν a)))]==𝕆[(Subscript[U, 1])[a->a, x->x], (E^(ℏ(μ (E^(-ℏ α ν))x+ν a)))]

Commuting (e^b) with (e^y):

$TD=5; 𝕆[(Subscript[U, 1])[b->b, y->y], (E^(ℏ(μ y+ν b)))]==𝕆[(Subscript[U, 1])[y->y,b->b], (E^(ℏ(μ (E^(-ℏ β ν))y+ν b)))]

The co-product of (e^a):

$TD=5; (Subscript[Δ, 1->1,2])[𝕆[(Subscript[U, 1])[a->a], (E^(ℏ μ a))]]==𝕆[(Subscript[U, 1])[(Subscript[a, 1])->a](Subscript[U, 2])[(Subscript[a, 2])->a], (E^(ℏ μ (Subscript[a, 1]))) (E^(ℏ μ (Subscript[a, 2])))]

The co-product of (Subscript[e, q]^x):

$TD=5 ; (𝕆[(Subscript[U, 1])[x->x], (Subscript[E, q])[ℏ μ x]] // (Subscript[Δ, 1->1,2]) // ExpandAB)==𝕆[(Subscript[U, 1])[(Subscript[a, 1])->a, (Subscript[x, 1])->x](Subscript[U, 2])[(Subscript[x, 2])->x], (Subscript[E, q])[ℏ μ (E^(-ℏ β (Subscript[a, 1])))(Subscript[x, 2])](Subscript[E, q])[ℏ μ (Subscript[x, 1])]]

The triple co-product of (Subscript[e, q]^x):

$TD=5; (𝕆[(Subscript[U, 1])[x->x], (Subscript[E, q])[ℏ μ x]] // (Subscript[Δ, 1->1,2,3]) // ExpandAB)-𝕆[(Subscript[U, 1])[(Subscript[a, 1])->a,(Subscript[x, 1])->x](Subscript[U, 2])[(Subscript[a, 2])->a, (Subscript[x, 2])->x](Subscript[U, 3])[(Subscript[x, 3])->x], (Subscript[E, q])[ℏ μ (E^(-ℏ β ((Subscript[a, 1])+(Subscript[a, 2]))))(Subscript[x, 3])](Subscript[E, q])[ℏ μ (E^(-ℏ β (Subscript[a, 1])))(Subscript[x, 2])](Subscript[E, q])[ℏ μ (Subscript[x, 1])]]

The co-product of (Subscript[e, q]^y):

$TD=5 ; (𝕆[(Subscript[U, 1])[y->y], (Subscript[E, q])[ℏ ν y]] // (Subscript[Δ, 1->1,2]) // ExpandAB)==𝕆[(Subscript[U, 1])[(Subscript[y, 1])->y](Subscript[U, 2])[(Subscript[y, 2])->y, (Subscript[b, 2])->b], (Subscript[E, q])[ℏ ν (Subscript[y, 2])](Subscript[E, q])[ℏ ν (E^(-ℏ α (Subscript[b, 2])))(Subscript[y, 1])]]

The triple co-product of (Subscript[e, q]^y):

$TD=5 ; (𝕆[(Subscript[U, 1])[y->y], (Subscript[E, q])[ℏ ν y]] // (Subscript[Δ, 1->1,2,3]) // ExpandAB)==𝕆[(Subscript[U, 1])[(Subscript[y, 1])->y](Subscript[U, 2])[(Subscript[y, 2])->y, (Subscript[b, 2])->b](Subscript[U, 3])[(Subscript[y, 3])->y,(Subscript[b, 3])->b], (Subscript[E, q])[ℏ ν (Subscript[y, 3])](Subscript[E, q])[ℏ ν (E^(-ℏ α (Subscript[b, 3])))(Subscript[y, 2])](Subscript[E, q])[ℏ ν (E^(-ℏ α ((Subscript[b, 2])+(Subscript[b, 3]))))(Subscript[y, 1])]]

The inverse-antipode on (Subscript[e, q]^x):

$TD=8; 
(𝕆[(Subscript[U, 1])[x->x], (Subscript[E, q])[ℏ μ x]]//(Subscript[Si, 1])//ExpandAB)-( 𝕆[(Subscript[U, 1])[a->a,x->x],Sum[(((((-ℏ μ))^k)(q^(-k(k+1)/2))(E^(ℏ β k a))(x^k))/(QFactorial[k,q])),{k,0,$TD}]])

Pairing (Subscript[e, q]^x) with (Subscript[e, q]^y):

$TD=5;
$TD*=2; lhs=𝕆[(Subscript[U, -1])[y->y], (Subscript[E, q])[ℏ ν y]]𝕆[(Subscript[U, 1])[x->x], (Subscript[E, q])[ℏ μ x]] // Expand // (Subscript[P, 1,-1])//ExpandAB;
($TD/=2; (Subscript[E, q])[ℏ μ ν]-lhs // ExpandAB)

Computing (e^(μ x))y (e^(-μ x)).

Following BBS:VanDerVeen-170620-212242, though with explicit ℏ put into μ, ν.

(Subscript[ϕ, 0])[x_] := (E^x);
(Subscript[ϕ, k_])[x_] := Module[{t},Simplify[(((E^t)-Normal@Series[(E^t),{t,0,k-1}])/(t^k)) /. t->x]];

Table[(Subscript[ϕ, k])[x], {k,0,3}]

$TD=5;
GS=T μ ((A^(-1)) (Subscript[ϕ, 1])[ℏ μ(q-1)x]-1)-μ (A (Subscript[ϕ, 1])[ℏ μ((q^(-1))-1)x]-1)/.{A->(E^(-ℏ β a))} ;
(G=𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x,a->a], GS])//DUForm
{lhs=𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x],(E^(ℏ μ x))]**(Subscript[DU, 1])[y]**𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x],(E^(-ℏ μ x))],
rhs=Expand[(Subscript[DU, 1])[y]+μ(T-1)(Subscript[DU, 1])[]+G],lhs-rhs/. T*ℰ_ :> (Subscript[DU, 1])[A[1]]**(Subscript[DU, 1])[B[1]]**ℰ} //Last//ExpandAB// DUForm

K=3; $TD=5;
GS1=μ T((A^(-1))(Subscript[ϕ, 1])[ℏ μ(q-1)x]-1)-μ(A (Subscript[ϕ, 1])[ℏ μ((q^(-1))-1)x]-1) /. {A->(E^(-ℏ β a))};
(G1=𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x,a->a], GS1]) // DUForm
Collect[ExpandAB[
Expand[(Subscript[DU, 1])[y]+(T-1)μ (Subscript[DU, 1])[]+G1-𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x],(E^(ℏ μ x))]**(Subscript[DU, 1])[y]**𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x],(E^(-ℏ μ x))]] /. T*ℰ_ :> ℰ**(Subscript[DU, 1])[A[1]]**(Subscript[DU, 1])[B[1]]
], β]

K=3; $TD=5;
GS2=Collect[Normal@Series[GS1, {β,0,K}],β, Factor];
(G2=𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x,a->a], GS2]) // DUForm
Collect[ExpandAB[
Expand[(Subscript[DU, 1])[y]+(T-1)μ (Subscript[DU, 1])[]+G2-𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x],(E^(ℏ μ x))]**(Subscript[DU, 1])[y]**𝕆[(Subscript[U, -1])[](Subscript[U, 1])[x->x],(E^(-ℏ μ x))]] /. T*ℰ_ :> ℰ**(Subscript[DU, 1])[A[1]]**(Subscript[DU, 1])[B[1]]
], β]

Clear[ℏ]

K=3; $TD=5;
GS1=μ T((A^(-1))(Subscript[ϕ, 1])[ℏ μ(q-1)x]-1)-μ(A (Subscript[ϕ, 1])[ℏ μ((q^(-1))-1)x]-1) /. {A->(E^(-ℏ β a))}

K=3;
GS2=Collect[Normal@Series[GS1, {β,0,K}],β, Factor]

Series[GS1-GS2, {ℏ,0,$TD}]

Series[Normal@Series[GS1-GS2, {ℏ,0,$TD}], {β, 0,K}]

Normal@Series[GS1-GS2, {ℏ,0,$TD}]+((O[β])^(K+1))

Series[GS1-GS2, {β,0,K}]