Pensieve header: Computations in the ybax algebra using the Drinfel’d double (at $\epsilon^2=0$. Continues ExpDoubleEpsilonSquare5@@.nb.

The double at (ϵ^2)=0

Utilities

Canonical Form:

CF[sd_SeriesData] := MapAt[CF,sd,3];
CF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[Expand[ℰ] //. (E^(x_))(E^(y_)):>(E^(x+y)) /. (E^(x_)):>(E^(CF[x]))];

The Kronecker δ:

Kδ/:(Subscript[Kδ, i_,j_]):=If[i===j,1,0];

Equality and multiplication of perturbed Gaussians; 𝔼[L,Q,P] stands for (e^(L+Q))P:

𝔼/:𝔼[L1_,Q1_,P1_]≡𝔼[L2_,Q2_,P2_]:=CF[L1==L2]∧CF[Q1==Q2]∧CF[Normal[P1-P2]==0];
𝔼/:𝔼[L1_,Q1_,P1_]𝔼[L2_,Q2_,P2_]:=𝔼[L1+L2,Q1+Q2,P1*P2];

Zip and Bind

{(SuperStar[b]),(SuperStar[y]),(SuperStar[a]),(SuperStar[x]),(SuperStar[z])}={β,η,α,ξ,ζ}; 
{(SuperStar[β]),(SuperStar[η]),(SuperStar[α]),(SuperStar[ξ]),(SuperStar[ζ])}={b,y,a,x,z}; (SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]);

expand[sd_SeriesData] := MapAt[expand,sd,3];
expand[ℰ_] := Expand[ℰ];
(Subscript[Zip, {}])[P_]:=P; (Subscript[Zip, {ζ_,ζs___}])[P_] := (expand[P//(Subscript[Zip, {ζs}])] /. f_.(ζ^(d_.)):>(∂_({(SuperStar[ζ]),d}))f) /. (SuperStar[ζ])->0

QZip implements the “Q-level zips” on 𝔼(L,Q,P)=((Pe)^(L+Q)). Such zips regard the L variables as scalars.

(Subscript[QZip, ζs_List,simp_])@𝔼[L_,Q_,P_] := Module[{ζ,z,zs,c,ys,ηs,qt,zrule,Q1,Q2},
zs=Table[(SuperStar[ζ]),{ζ,ζs}];
c=Q/.Alternatives@@(ζs⋃zs)->0;
ys=Table[(∂_ζ)(Q/.Alternatives@@zs->0),{ζ,ζs}];
ηs=Table[(∂_z)(Q/.Alternatives@@ζs->0),{z,zs}];
qt=Inverse@Table[(Subscript[Kδ, z,(SuperStar[ζ])])-(∂_(z,ζ))Q,{ζ,ζs},{z,zs}];
zrule=Thread[zs->qt.(zs+ys)];
Q2=(Q1=c+ηs.zs/.zrule)/.Alternatives@@zs->0;
simp /@ 𝔼[L,Q2,Det[qt](E^(-Q2))(Subscript[Zip, ζs])[(E^Q1)(P/.zrule)]] ];
(Subscript[QZip, ζs_List]):=(Subscript[QZip, ζs,CF]);

Upper to lower and lower to Upper:

U2l={(Subscript[B, i_]^(p_.))->(E^(-p (Subscript[b, i]))),(B^(p_.))->(E^(-p b)), (Subscript[𝒜, i_]^(p_.))->(E^(p (Subscript[α, i]))),(𝒜^(p_.))->(E^(p α))}; 
l2U={(E^(c_.(Subscript[b, i_])+d_.)):>(Subscript[B, i]^(-c))(E^d),(E^(c_.b+d_.)):>(B^(-c))(E^d),
(E^(c_.(Subscript[α, i_])+d_.)):>(Subscript[𝒜, i]^c)(E^d),(E^(c_.α+d_.)):>(𝒜^c)(E^d),
(E^(ℰ_)):>(E^(Expand@ℰ))};

LZip implements the “L-level zips” on 𝔼(L,Q,P)=((Pe)^(L+Q)). Such zips regard all of ((Pe)^Q) as a single”P”. Here the z’s are b and α and the ζ’s are β and a.

(Subscript[LZip, ζs_List,simp_])@𝔼[L_,Q_,P_] := Module[{ζ,z,zs,c,ys,ηs,lt,zrule,L1,L2,Q1,Q2},
zs=Table[(SuperStar[ζ]),{ζ,ζs}];
c=L/.Alternatives@@(ζs⋃zs)->0;
ys=Table[(∂_ζ)(L/.Alternatives@@zs->0),{ζ,ζs}];
ηs=Table[(∂_z)(L/.Alternatives@@ζs->0),{z,zs}];
lt=Inverse@Table[(Subscript[Kδ, z,(SuperStar[ζ])])-(∂_(z,ζ))L,{ζ,ζs},{z,zs}];
zrule=Thread[zs->lt.(zs+ys)];
L2=(L1=c+ηs.zs/.zrule)/.Alternatives@@zs->0;
Q2=(Q1=Q/.U2l/.zrule)/.Alternatives@@zs->0;
simp /@ 𝔼[L2,Q2,Det[lt](E^(-L2-Q2))(Subscript[Zip, ζs])[(E^(L1+Q1))(P/.U2l/.zrule)]]//.l2U ];
(Subscript[LZip, ζs_List]):=(Subscript[LZip, ζs,CF]);

(Subscript[Bind, {}])[L_,R_]:=L R;
(Subscript[Bind, {is__}])[L_𝔼,R_𝔼] := Module[{n},
Times[
L/.Table[(Subscript[(v:b|B|a|x|y), i])->(Subscript[v, n@i]),{i,{is}}],
R/.Table[(Subscript[(v:β|α|𝒜|ξ|η), i])->(Subscript[v, n@i]),{i,{is}}]
] // (Subscript[LZip, Flatten@Table[{(Subscript[β, n@i]),(Subscript[a, n@i])},{i,{is}}]]) // (Subscript[QZip, Flatten@Table[{(Subscript[ξ, n@i]),(Subscript[y, n@i])},{i,{is}}]]) ];
(Subscript[B, l_List])[L_,R_]:=(Subscript[Bind, l])[L,R]; (Subscript[B, is___])[L_,R_]:=(Subscript[Bind, {is}])[L,R];

The two halves

(*Hopf algebra on the a,x side*)
(Subscript[tam, i_,j_->k_]):=𝔼[((Subscript[α, i])+(Subscript[α, j]))(Subscript[a, k]),((E^(-(Subscript[α, j])))(Subscript[ξ, i])+(Subscript[ξ, j]))(Subscript[x, k]),1+((O[ϵ])^2)]
(Subscript[taΔ, i_->j_,k_]):=𝔼[(Subscript[α, i])((Subscript[a, j])+(Subscript[a, k])),(Subscript[ξ, i])((Subscript[x, j])+(Subscript[x, k])),1+ϵ (Subscript[ξ, i])(Subscript[x, k])( -(Subscript[a, j])+(1/2) (Subscript[ξ, i]) (Subscript[x, j]))+((O[ϵ])^2)]
(Subscript[taS, i_]) :=𝔼[-(Subscript[α, i])(Subscript[a, i]),- (E^( (Subscript[α, i])))(Subscript[ξ, i])(Subscript[x, i]),1- ϵ (E^( (Subscript[α, i]))) (Subscript[ξ, i])(Subscript[x, i])((Subscript[a, i])+ (1/2) (E^( (Subscript[α, i])))(Subscript[ξ, i])(Subscript[x, i]))+((O[ϵ])^2)]
(Subscript[taSi, i_]):=𝔼[-(Subscript[α, i])(Subscript[a, i]),-(E^( (Subscript[α, i]))) (Subscript[ξ, i])(Subscript[x, i]),1- ϵ (E^( (Subscript[α, i]))) (Subscript[ξ, i])(Subscript[x, i])((Subscript[a, i])-1+ (1/2) (E^( (Subscript[α, i])))(Subscript[ξ, i])(Subscript[x, i]))+((O[ϵ])^2)]
(*Hopf algebra on the y,b side*)
(Subscript[tbm, i_,j_->k_]):=𝔼[((Subscript[β, i])+(Subscript[β, j]))(Subscript[b, k]),((Subscript[η, i])+(Subscript[η, j]))(Subscript[y, k]),1- ϵ  (Subscript[η, j])(Subscript[y, k])(Subscript[β, i])+((O[ϵ])^2)]
(Subscript[tbΔ, i_->j_,k_]):=𝔼[(Subscript[β, i])((Subscript[b, j])+(Subscript[b, k])),(Subscript[η, i])((E^(-(Subscript[b, k])))(Subscript[y, j])+(Subscript[y, k])),1+(1/2)ϵ ((Subscript[η, i])^2)(Subscript[y, j])(Subscript[y, k])(E^(-(Subscript[b, k])))+((O[ϵ])^2)]
(Subscript[tbS, i_]):=𝔼[-(Subscript[β, i])(Subscript[b, i]),-(E^( (Subscript[b, i])))(Subscript[η, i])(Subscript[y, i]),1-ϵ (E^( (Subscript[b, i]))) (Subscript[η, i])(Subscript[y, i])( (Subscript[β, i])+ (1/2)(E^(Subscript[b, i])) (Subscript[η, i])(Subscript[y, i]))+((O[ϵ])^2)]
(Subscript[tbSi, i_]):=𝔼[-(Subscript[β, i])(Subscript[b, i]),-(E^(Subscript[b, i]))(Subscript[η, i])(Subscript[y, i]),1-ϵ (E^( (Subscript[b, i]))) (Subscript[η, i])(Subscript[y, i])( (Subscript[β, i])-1+ (1/2)(E^(Subscript[b, i])) (Subscript[η, i])(Subscript[y, i]))+((O[ϵ])^2)]

First check that on the generators this agrees with our conventions in SLPortfolio.pdf with ℏ = γ = 1

{
"[a,x]"->((𝔼[0,0,(Subscript[a, 2])(Subscript[x, 1])]~(Subscript[B, 1,2])~(Subscript[tam, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[a, 1])(Subscript[x, 2])]~(Subscript[B, 1,2])~(Subscript[tam, 1,2->1]))[[3]]),
"[b,y]"->((𝔼[0,0,(Subscript[y, 2])(Subscript[b, 1])]~(Subscript[B, 1,2])~(Subscript[tbm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[y, 1])(Subscript[b, 2])]~(Subscript[B, 1,2])~(Subscript[tbm, 1,2->1]))[[3]])
}/.{(Subscript[z_, 1])->z}//Simplify
(Δ[#]->Simplify@Normal@Last[𝔼[0,0,(Subscript[#, 1])]~(Subscript[B, 1])~(Subscript[taΔ, 1->1,2])])&/@{a,x}
(Δ[#]->Simplify@Normal@Last[𝔼[0,0,(Subscript[#, 1])]~(Subscript[B, 1])~(Subscript[tbΔ, 1->1,2])])&/@{b,y}
{
" S(a) = "((𝔼[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[taS, 1]))[[3]]),
" S(x) = "((𝔼[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[taS, 1]))[[3]]),
" S(b) = "((𝔼[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[tbS, 1]))[[3]]),
" S(y) = "->((𝔼[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[tbS, 1]))[[3]])
}/.{(Subscript[z_, 1])->z}//Simplify

Hopf algebra axioms on both sides separately

(co)-associativity on both sides

{((Subscript[taΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[taΔ, 2->2,3]))≡((Subscript[taΔ, 1->1,3])~(Subscript[B, 1])~(Subscript[taΔ, 1->1,2])),((Subscript[tbΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[tbΔ, 2->2,3]))≡((Subscript[tbΔ, 1->1,3])~(Subscript[B, 1])~(Subscript[tbΔ, 1->1,2])),((Subscript[tam, 1,2->1])~(Subscript[B, 1])~(Subscript[tam, 1,3->1]))≡((Subscript[tam, 2,3->2])~(Subscript[B, 2])~(Subscript[tam, 1,2->1])),((Subscript[tbm, 1,2->1])~(Subscript[B, 1])~(Subscript[tbm, 1,3->1]))≡((Subscript[tbm, 2,3->2])~(Subscript[B, 2])~(Subscript[tbm, 1,2->1]))}

Δ is an algebra morphism

{(Subscript[tam, 1,2->1])~(Subscript[B, 1])~(Subscript[taΔ, 1->1,2])≡((Subscript[taΔ, 1->1,3])(Subscript[taΔ, 2->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tam, 3,4->2])(Subscript[tam, 1,2->1])),
(Subscript[tbm, 1,2->1])~(Subscript[B, 1])~(Subscript[tbΔ, 1->1,2])≡((Subscript[tbΔ, 1->1,3])(Subscript[tbΔ, 2->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tbm, 3,4->2])(Subscript[tbm, 1,2->1]))}

S is convolution inverse of id

{((Subscript[taΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[taS, 1]))~(Subscript[B, 1,2])~(Subscript[tam, 1,2->1]),((Subscript[taΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[taS, 2]))~(Subscript[B, 1,2])~(Subscript[tam, 1,2->1])}
{((Subscript[tbΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[tbS, 1]))~(Subscript[B, 1,2])~(Subscript[tbm, 1,2->1]),((Subscript[tbΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[tbS, 2]))~(Subscript[B, 1,2])~(Subscript[tbm, 1,2->1])}

Si is the inverse of S

{(Subscript[taSi, 1])~(Subscript[B, 1])~(Subscript[taS, 1])≡𝔼[(Subscript[a, 1]) (Subscript[α, 1]),(Subscript[x, 1]) (Subscript[ξ, 1]),1],(Subscript[taS, 1])~(Subscript[B, 1])~(Subscript[taSi, 1])≡𝔼[(Subscript[a, 1]) (Subscript[α, 1]),(Subscript[x, 1]) (Subscript[ξ, 1]),1]}
{(Subscript[tbSi, 1])~(Subscript[B, 1])~(Subscript[tbS, 1])≡𝔼[(Subscript[b, 1]) (Subscript[β, 1]),(Subscript[y, 1]) (Subscript[η, 1]),1],(Subscript[tbS, 1])~(Subscript[B, 1])~(Subscript[tbSi, 1])≡𝔼[(Subscript[b, 1]) (Subscript[β, 1]),(Subscript[y, 1]) (Subscript[η, 1]),1]}

S is an algebra anti-(co)morphism

{(Subscript[tam, 1,2->1])~(Subscript[B, 1])~(Subscript[taS, 1])≡((Subscript[taS, 1])(Subscript[taS, 2]))~(Subscript[B, 1,2])~(Subscript[tam, 2,1->1]),(Subscript[tbm, 1,2->1])~(Subscript[B, 1])~(Subscript[tbS, 1])≡((Subscript[tbS, 1])(Subscript[tbS, 2]))~(Subscript[B, 1,2])~(Subscript[tbm, 2,1->1])}
{(Subscript[taS, 1])~(Subscript[B, 1])~(Subscript[taΔ, 1->1,2])≡(Subscript[taΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[taS, 1])(Subscript[taS, 2])),(Subscript[tbS, 1])~(Subscript[B, 1])~(Subscript[tbΔ, 1->1,2])≡(Subscript[tbΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[tbS, 1])(Subscript[tbS, 2]))}

Pairing

(Subscript[tP, i_,j_]):=𝔼[(Subscript[β, i])(Subscript[α, j]),(Subscript[η, i])(Subscript[ξ, j]),1+(1/4)ϵ ((Subscript[η, i])^2)((Subscript[ξ, j])^2)]

qfac[k_,q_]:=(((1-q))^(-k))QPochhammer[q,q,k]//FunctionExpand
qfe[k_]:=Normal[Series[qfac[k,E^ρ],{ρ,0,1}]]/.{ρ->ϵ}
Table[𝔼[0,0,((Subscript[y, 1])^r)((Subscript[b, 1])^s)((Subscript[a, 2])^t)((Subscript[x, 2])^u)]~(Subscript[B, 1,2])~(Subscript[tP, 1,2])≡𝔼[0,0,(Subscript[Kδ, r,u])(Subscript[Kδ, s,t])qfe[r]s!],{r,0,4},{s,0,4},{t,0,4},{u,0,4}]//Flatten//Union

Pairing axioms

{((Subscript[tbm, 1,2->1]) 𝔼[(Subscript[α, 3])(Subscript[a, 3]),(Subscript[ξ, 3])(Subscript[x, 3]),1])~(Subscript[B, 1,3])~(Subscript[tP, 1,3])≡( 𝔼[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1]𝔼[(Subscript[β, 2])(Subscript[b, 2]),(Subscript[η, 2])(Subscript[y, 2]),1](Subscript[taΔ, 3->4,5]))~(Subscript[B, 1,4])~(Subscript[tP, 1,4])~(Subscript[B, 2,5])~(Subscript[tP, 2,5])
,((Subscript[tbΔ, 1->1,2]) 𝔼[(Subscript[α, 3])(Subscript[a, 3]),(Subscript[ξ, 3])(Subscript[x, 3]),1]𝔼[(Subscript[α, 4])(Subscript[a, 4]),(Subscript[ξ, 4])(Subscript[x, 4]),1])~(Subscript[B, 1,3])~(Subscript[tP, 1,3])~(Subscript[B, 2,4])~(Subscript[tP, 2,4])≡( 𝔼[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1](Subscript[tam, 3,4->3]))~(Subscript[B, 1,3])~(Subscript[tP, 1,3]) }

{((Subscript[tbS, 1])𝔼[(Subscript[α, 2])(Subscript[a, 2]),(Subscript[ξ, 2])(Subscript[x, 2]),1])~(Subscript[B, 1,2])~(Subscript[tP, 1,2])≡(𝔼[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1](Subscript[taS, 2]))~(Subscript[B, 1,2])~(Subscript[tP, 1,2]),
((Subscript[tbSi, 1])𝔼[(Subscript[α, 2])(Subscript[a, 2]),(Subscript[ξ, 2])(Subscript[x, 2]),1])~(Subscript[B, 1,2])~(Subscript[tP, 1,2])≡(𝔼[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1](Subscript[taSi, 2]))~(Subscript[B, 1,2])~(Subscript[tP, 1,2])}

The Double

The double multiplication (should really bind the a’s and b’s separately)

Block[{i,j,k}, (Subscript[tdm, i_,j_->k_])=Simplify/@Expand/@((𝔼[(Subscript[β, i])(Subscript[b, i]) + (Subscript[α, j])(Subscript[a, j]),(Subscript[η, i])(Subscript[y, i])+(Subscript[ξ, j])(Subscript[x, j]),1]((Subscript[taΔ, i->h1,h2])~(Subscript[B, h2])~(Subscript[taΔ, h2->h2,h3]))((Subscript[tbΔ, j->t1,t2])~(Subscript[B, t2])~(Subscript[tbΔ, t2->t2,t3])))~(Subscript[B, h3])~(Subscript[taSi, h3])~(Subscript[B, t1,h3])~((Subscript[tP, t1,h3]))~(Subscript[B, t3,h1])~((Subscript[tP, t3,h1]))~(Subscript[B, h2,j,i,t2])~((Subscript[tam, h2,j->k])(Subscript[tbm, i,t2->-k]))/.{(Subscript[u_, -k]):>(Subscript[u, k])}) ]

(*Deriving tdS using tdm*)
Block[{i},(Subscript[tdS, i_])=(((Subscript[tbSi, 1])(Subscript[taS, 2]))~(Subscript[B, 1,2])~(Subscript[tdm, 2,1->i]))/.{(Subscript[z_, 1|2])->(Subscript[z, i])}]

(*Deriving tdΔ using tdm*)
Block[{i,j,k},(Subscript[tdΔ, i_->j_,k_])=((Subscript[tbΔ, i->3,1])(Subscript[taΔ, i->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tdm, 3,4->k])(Subscript[tdm, 1,2->j]))]

First check the double formulas on the generators agree with SL2Portfolio.pdf:

{
"[a,y]"-> ((𝔼[0,0,(Subscript[y, 2])(Subscript[a, 1])]~(Subscript[B, 1,2])~(Subscript[tdm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[y, 1])(Subscript[a, 2])]~(Subscript[B, 1,2])~(Subscript[tdm, 1,2->1]))[[3]]),
"[b,x]"   ->((𝔼[0,0,(Subscript[x, 2])(Subscript[b, 1])]~(Subscript[B, 1,2])~(Subscript[tdm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[x, 1])(Subscript[b, 2])]~(Subscript[B, 1,2])~(Subscript[tdm, 1,2->1]))[[3]]),"xy-qyx"->((𝔼[0,0,(Subscript[x, 1])(Subscript[y, 2])]~(Subscript[B, 1,2])~(Subscript[tdm, 1,2->1]))[[3]]-(1+ϵ)(𝔼[0,0,(Subscript[y, 1])(Subscript[x, 2])]~(Subscript[B, 1,2])~(Subscript[tdm, 1,2->1]))[[3]])
}/.{(Subscript[z_, 1])->z}//Expand//Factor
{
"Δ(a)"->((𝔼[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[tdΔ, 1->1,2]))[[3]]),
"Δ(x)"->((𝔼[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[tdΔ, 1->1,2]))[[3]]),
"Δ(b)"->((𝔼[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[tdΔ, 1->1,2]))[[3]]),
"Δ(y)"->((𝔼[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[tdΔ, 1->1,2]))[[3]])
}//Simplify
{
"S(a)"->((𝔼[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[tdS, 1]))[[3]]),
"S(x)"->((𝔼[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[tdS, 1]))[[3]]),
"S(b)"->((𝔼[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[tdS, 1]))[[3]]),
"S(y)"->((𝔼[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[tdS, 1]))[[3]])
}/.{(Subscript[z_, 1])->z}//Simplify

Hopf algebra axioms on double

(co)-associativity

{((Subscript[tdΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[tdΔ, 2->2,3]))≡((Subscript[tdΔ, 1->1,3])~(Subscript[B, 1])~(Subscript[tdΔ, 1->1,2])),
((Subscript[tdm, 1,2->1])~(Subscript[B, 1])~(Subscript[tdm, 1,3->1]))≡((Subscript[tdm, 2,3->2])~(Subscript[B, 2])~(Subscript[tdm, 1,2->1]))}

Δ is an algebra morphism

(Subscript[tdm, 1,2->1])~(Subscript[B, 1])~(Subscript[tdΔ, 1->1,2])≡((Subscript[tdΔ, 1->1,3])(Subscript[tdΔ, 2->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tdm, 3,4->2])(Subscript[tdm, 1,2->1]))

S is convolution inverse of id

{((Subscript[tdΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[tdS, 1]))~(Subscript[B, 1,2])~(Subscript[tdm, 1,2->1]),((Subscript[tdΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[tdS, 2]))~(Subscript[B, 1,2])~(Subscript[tdm, 1,2->1])}

S is a (co)-algebra anti-morphism

{(Subscript[tdm, 1,2->1])~(Subscript[B, 1])~(Subscript[tdS, 1])≡((Subscript[tdS, 1])(Subscript[tdS, 2]))~(Subscript[B, 1,2])~(Subscript[tdm, 2,1->1]),(Subscript[tdS, 1])~(Subscript[B, 1])~(Subscript[tdΔ, 1->1,2])≡(Subscript[tdΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[tdS, 1])(Subscript[tdS, 2]))}//Expand

R-matrix

(Subscript[E, q_,k_])[x_]:=E^((∑_(j=1)^(k+1)) (((((1-q))^j)(x^j))/(j(1-(q^j)))))
(Subscript[tR, i_,j_]):=𝔼[(Subscript[b, i])(Subscript[a, j]),(Subscript[y, i])(Subscript[x, j]),1- ϵ(1/4) (Subscript[y, i]^2)(Subscript[x, j]^2) +((O[ϵ])^2)](*First two terms in Faddeev-Quesne formula*)

Series[(Subscript[E, q,1])[z]/.{z->(Subscript[y, i])(Subscript[x, j]),q->1+ρ},{ρ,0,1}]/.{ρ->ϵ}

Quasi-triangular axiom 1:

(Subscript[tR, 1,2])~(Subscript[B, 1])~(Subscript[tdΔ, 1->1,3])≡((Subscript[tR, 1,4])(Subscript[tR, 3,2]))~(Subscript[B, 2,4])~(Subscript[tdm, 2,4->2])

Quasi-triangular axiom 2:

(((Subscript[tdΔ, 1->1,2])(Subscript[tR, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tdm, 1,3->1])(Subscript[tdm, 2,4->2])))≡
(((Subscript[tdΔ, 1->2,1])(Subscript[tR, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tdm, 3,1->1])(Subscript[tdm, 4,2->2])))

Reidemeister 3:

(((Subscript[tR, 1,2])(Subscript[tR, 4,3])(Subscript[tR, 5,6]))~(Subscript[B, 1,4])~(Subscript[tdm, 1,4->1])~(Subscript[B, 2,5])~(Subscript[tdm, 2,5->2])~(Subscript[B, 3,6])~(Subscript[tdm, 3,6->3]) )≡
(((Subscript[tR, 1,6])(Subscript[tR, 2,3])(Subscript[tR, 4,5]))~(Subscript[B, 1,4])~(Subscript[tdm, 1,4->1])~(Subscript[B, 2,5])~(Subscript[tdm, 2,5->2])~(Subscript[B, 3,6])~(Subscript[tdm, 3,6->3]))

Block[{i,j}, (Subscript[(OverBar[tR]), i_,j_])=Expand/@(Subscript[tR, i,j])~(Subscript[B, j])~(Subscript[tdS, j])]

Reidemeister 2

{((Subscript[(OverBar[tR]), 1,2])(Subscript[tR, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tdm, 1,3->1])(Subscript[tdm, 2,4->2])),((Subscript[tR, 1,2])(Subscript[(OverBar[tR]), 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tdm, 1,3->1])(Subscript[tdm, 2,4->2]))}

dm=tdm; dS=tdS; dΔ=tdΔ; R=tR;

Deriving the Drinfeld element u and its inverse ui

Block[{i},{
(Subscript[u, i_])=(Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[dS, 1])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->i]),
(Subscript[ui, i_]):=(Subscript[R, 1,2])~(Subscript[B, 2])~(Subscript[dS, 2])~(Subscript[B, 2])~(Subscript[dS, 2])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->i])
}]

u and ui are inverses

((Subscript[u, 1])(Subscript[ui, 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])

The ribbon element v satisfies (v^2)=S(u)u. The spinner C=(uv^(-1)).
It is convenient to compute z=S(u)(u^(-1)) which is something easy.

(((Subscript[u, 1])~(Subscript[B, 1])~(Subscript[dS, 1]))(Subscript[ui, 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])

(* Needs fixing! *) So in our case S(u) = u z so S(u)u = (u^2)z and v = (uz^(1/2)) and finally C = (uv^(-1)) = (z^(-(1/2)))=(e^((Subscript[t, 1])/2))(1-ϵ (Subscript[a, 1])).

Block[{i},
{(Subscript[CC, i_])=𝔼[0,0,(Subscript[B, i]^(1/2))(E^(-ϵ (Subscript[a, i])/2))+((O[ϵ])^2)],
(Subscript[(OverBar[CC]), i_])=𝔼[0,0,(Subscript[B, i]^(-1/2))(E^(ϵ (Subscript[a, i])/2))+((O[ϵ])^2)]
}]

Block[{i,j},{
(Subscript[Kink, i_]) = ((Subscript[R, 1,3])(Subscript[(OverBar[CC]), 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[dm, 1,3->i]),
(Subscript[(OverBar[Kink]), j_]) = ((Subscript[(OverBar[R]), 1,3])(Subscript[CC, 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[dm, 1,3->j])
}]

k2=((Subscript[R, 3,1])(Subscript[CC, 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[dm, 1,3->i])/.𝕖->E;
k4=((Subscript[(OverBar[R]), 3,1])(Subscript[(OverBar[CC]), 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[dm, 1,3->j])/.𝕖->E;
Simplify@{(Subscript[Kink, i])≡k2,(Subscript[(OverBar[Kink]), j])≡k4,((Subscript[Kink, i]) (Subscript[(OverBar[Kink]), j]))~(Subscript[B, i,j])~(Subscript[dm, i,j->1])}

Reidemeister 2:

((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4]))~(Subscript[B, 1,3])~(Subscript[dm, 1,3->1])~(Subscript[B, 2,4])~(Subscript[dm, 2,4->2])

Cyclic Reidemeister 2:

((Subscript[R, 1,4])(Subscript[(OverBar[R]), 5,2])(Subscript[(OverBar[CC]), 3]))~(Subscript[B, 2,4])~(Subscript[dm, 2,4->2])~(Subscript[B, 1,3])~(Subscript[dm, 1,3->1])~(Subscript[B, 1,5])~(Subscript[dm, 1,5->1])≡(Subscript[(OverBar[CC]), 1])

Trefoil

Timing[
Z=(Subscript[R, 1,5])(Subscript[R, 6,2])(Subscript[R, 3,7])(Subscript[(OverBar[CC]), 4])(Subscript[(OverBar[Kink]), 8])(Subscript[(OverBar[Kink]), 9])(Subscript[(OverBar[Kink]), 10]);
Do[Print["doing ", r]; Z=Z~(Subscript[B, 1,r])~(Subscript[dm, 1,r->1]),{r,2,10}];
Simplify@Z[[3]] ]