The tensorial double at (ϵ^2)=0

ϵ /: (ϵ^(d_. ))/;d>1 :=0;

CF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[Expand[ℰ] //. (E^(x_))(E^(y_)):>(E^(x+y)) /. (E^(x_)):>(E^(CF[x]))];
Kδ/:(Subscript[Kδ, i_,j_]):=If[i===j,1,0];

Zip and Bind

𝔼/:𝔼[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];

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

(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]);

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,ηsrule,lt,zrule,L1,L2,Q1,Q2},
(*Print["LZipping"];*)
(*ζs//Echo;*)
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}];
ηsrule= Table[(SuperStar[z])->(∂_z)(L/.Alternatives@@ζs->0),{z,zs}];(*NEW*)
lt=Inverse@Table[(Subscript[Kδ, z,(SuperStar[ζ])])-(∂_(z,ζ))L,{ζ,ζs},{z,zs}];
zrule=Thread[zs->lt.(zs+ys)];
L1=c+ηs.zs/.zrule;
L2=L1/.Alternatives@@zs->0;
Q1=Q/.Join[zrule,ηsrule];
Q2=Q1/.Join[{Alternatives@@zs->0},ηsrule];
(*{Det[lt](E^(-L2-Q2)),(Subscript[Zip, ζs])[(E^(L1+Q1))(P/.zrule)]}//Echo;*)
simp /@ 𝔼[L2,Q2,Det[lt](E^(-L2-Q2))(Subscript[Zip, ζs])[(E^(L1+Q1))(P/.zrule)]] ];
(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:t|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[β, 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]):=(Subscript[Bind, l]); (Subscript[B, is___]):=(Subscript[Bind, {is}]);

The two halves

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

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]])
}/.{𝕖->E,(Subscript[z_, 1])->z}//Simplify
{
" Δ(a) = "((𝔼[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[taΔ, 1->1,2]))[[3]]),
" Δ(x) = "((𝔼[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[taΔ, 1->1,2]))[[3]]),
" Δ(b) = "((𝔼[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[tbΔ, 1->1,2]))[[3]]),
" Δ(y) = "((𝔼[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[tbΔ, 1->1,2]))[[3]])
}/.{𝕖->E}//Simplify
{
" 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]])
}/.{𝕖->E,(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]))}/.𝕖->E

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])}/.𝕖->E
{((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])}/.𝕖->E

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]}/.𝕖->E
{(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]}/.𝕖->E

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])}/.𝕖->E
{(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]))}/.𝕖->E

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)

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]))/.{𝕖->E,(Subscript[u_, -k]):>(Subscript[u, k])})

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

(*Deriving tdΔ using tdm*)
((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]))

(Subscript[tdm, i_,j_->k_]):=𝔼[(Subscript[a, k]) ((Subscript[α, i])+(Subscript[α, j]))+(Subscript[b, k]) ((Subscript[β, i])+(Subscript[β, j])),(Subscript[y, k]) ((Subscript[η, i])+(E^(-(Subscript[α, i]))) (Subscript[η, j]))+(E^(-(Subscript[b, k]))) (-1+(E^(Subscript[b, k]))) (Subscript[η, j]) (Subscript[ξ, i])+(Subscript[x, k]) ((E^(-(Subscript[α, j]))) (Subscript[ξ, i])+(Subscript[ξ, j])),(1/4) (E^(-2 (Subscript[b, k])-(Subscript[α, i])-(Subscript[α, j]))) (2 (E^(Subscript[b, k])) ϵ (Subscript[y, k]) (Subscript[η, j]) (-2 (E^((Subscript[b, k])+(Subscript[α, j]))) (Subscript[β, i])+(2 (E^(Subscript[b, k])) (Subscript[x, k])+(E^(Subscript[α, j])) (-3+(E^(Subscript[b, k]))) (Subscript[η, j])) (Subscript[ξ, i]))+(E^(Subscript[α, i])) (2 (E^(Subscript[b, k])) ϵ (Subscript[x, k]) (Subscript[ξ, i]) (-2 (E^(Subscript[b, k])) (Subscript[β, j])+(-3+(E^(Subscript[b, k]))) (Subscript[η, j]) (Subscript[ξ, i]))+(E^(Subscript[α, j])) (4 (E^(2 (Subscript[b, k])))+4 (E^(Subscript[b, k])) ϵ (Subscript[a, k]) (Subscript[η, j]) (Subscript[ξ, i])+(3-4 (E^(Subscript[b, k]))+(E^(2 (Subscript[b, k])))) ϵ (Subscript[η, j]^2) (Subscript[ξ, i]^2))))]
(Subscript[tdΔ, i_->j_,k_]):=𝔼[(Subscript[a, j]) (Subscript[α, i])+(Subscript[a, k]) (Subscript[α, i])+(Subscript[b, j]) (Subscript[β, i])+(Subscript[b, k]) (Subscript[β, i]),(𝕖^(-(Subscript[b, j]))) ((𝕖^(Subscript[b, j])) (Subscript[y, j]) (Subscript[η, i])+(Subscript[y, k]) (Subscript[η, i])+(𝕖^(Subscript[b, j])) (Subscript[x, j]) (Subscript[ξ, i])+(𝕖^(Subscript[b, j])) (Subscript[x, k]) (Subscript[ξ, i])),(1/2) (𝕖^(-(Subscript[b, j]))) (2 (𝕖^(Subscript[b, j]))+ϵ (Subscript[y, j]) (Subscript[y, k]) (Subscript[η, i]^2)-2 (𝕖^(Subscript[b, j])) ϵ (Subscript[a, j]) (Subscript[x, k]) (Subscript[ξ, i])+(𝕖^(Subscript[b, j])) ϵ (Subscript[x, j]) (Subscript[x, k]) (Subscript[ξ, i]^2))]
(Subscript[tdS, i_]):=𝔼[-(Subscript[a, i]) (Subscript[α, i])-(Subscript[b, i]) (Subscript[β, i]),(E^(-(Subscript[b, i]))) (-(E^(2 (Subscript[b, i])+(Subscript[α, i]))) (Subscript[y, i]) (Subscript[η, i])-(E^((Subscript[b, i])+(Subscript[α, i]))) (Subscript[x, i]) (Subscript[ξ, i])-(E^((Subscript[b, i])+(Subscript[α, i]))) (Subscript[η, i]) (Subscript[ξ, i])+(E^(2 (Subscript[b, i])+(Subscript[α, i]))) (Subscript[η, i]) (Subscript[ξ, i])),(1/4) (E^(-2 (Subscript[b, i]))) (4 (E^(2 (Subscript[b, i])))+4 (E^(3 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[y, i]) (Subscript[η, i])-4 (E^(3 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[y, i]) (Subscript[β, i]) (Subscript[η, i])-2 (E^(4 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[y, i]^2) (Subscript[η, i]^2)-4 (E^(2 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[a, i]) (Subscript[x, i]) (Subscript[ξ, i])-4 (E^(2 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[x, i]) (Subscript[β, i]) (Subscript[ξ, i])+4 (E^(2 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[η, i]) (Subscript[ξ, i])-4 (E^(3 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[η, i]) (Subscript[ξ, i])+4 (E^(3 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[a, i]) (Subscript[η, i]) (Subscript[ξ, i])-4 (E^(3 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[x, i]) (Subscript[y, i]) (Subscript[η, i]) (Subscript[ξ, i])-4 (E^(2 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[β, i]) (Subscript[η, i]) (Subscript[ξ, i])+4 (E^(3 (Subscript[b, i])+(Subscript[α, i]))) ϵ (Subscript[β, i]) (Subscript[η, i]) (Subscript[ξ, i])-2 (E^(3 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[y, i]) (Subscript[η, i]^2) (Subscript[ξ, i])+6 (E^(4 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[y, i]) (Subscript[η, i]^2) (Subscript[ξ, i])-2 (E^(2 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[x, i]^2) (Subscript[ξ, i]^2)-2 (E^(2 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[x, i]) (Subscript[η, i]) (Subscript[ξ, i]^2)+6 (E^(3 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[x, i]) (Subscript[η, i]) (Subscript[ξ, i]^2)-(E^(2 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[η, i]^2) (Subscript[ξ, i]^2)+4 (E^(3 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[η, i]^2) (Subscript[ξ, i]^2)-3 (E^(4 (Subscript[b, i])+2 (Subscript[α, i]))) ϵ (Subscript[η, i]^2) (Subscript[ξ, i]^2))]

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,𝕖->E}//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]])
}/.{𝕖->E}//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,𝕖->E}//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]))/.𝕖->E//Timing

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])}/.𝕖->E//Timing

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]))}/.𝕖->E//Expand//Timing

R-matrix

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

(Subscript[𝕖, q_,k_])[x_]:=𝕖^((∑_(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) ](*First two terms in Faddeev-Quesne formula*)

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])/.{𝕖->E}

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]))/.{𝕖->E})≡
(((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]))/.{𝕖->E})

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]) /.𝕖->E)≡
(((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])/.𝕖->E)//Timing

(*Deriving t(OverBar[R]) formula*)
Expand/@(Subscript[tR, i,j])~(Subscript[B, j])~(Subscript[tdS, j])

(Subscript[(OverBar[tR]), i_,j_]):=𝔼[-(Subscript[a, j]) (Subscript[b, i]),-(E^(Subscript[b, i])) (Subscript[x, j]) (Subscript[y, i]),1-(E^(Subscript[b, i])) ϵ (Subscript[a, j]) (Subscript[x, j]) (Subscript[y, i])-(3/4) (E^(2 (Subscript[b, i]))) ϵ (Subscript[x, j]^2) (Subscript[y, i]^2)]

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

Changing to the central variable t

The full zipping procedure only works when the coefficient functions commute. 
We therefore need to introduce the central element t = ϵ a - b.

(Subscript[b2t, i_]):=𝔼[(Subscript[α, i])(Subscript[a, i])-(Subscript[β, i])(Subscript[t, i]),(Subscript[ξ, i])(Subscript[x, i])+(Subscript[η, i])(Subscript[y, i]),1+ϵ (Subscript[β, i])(Subscript[a, i])]
(Subscript[t2b, i_]):=𝔼[(Subscript[α, i])(Subscript[a, i])-(Subscript[τ, i])(Subscript[b, i]),(Subscript[ξ, i])(Subscript[x, i])+(Subscript[η, i])(Subscript[y, i]),1+ϵ (Subscript[τ, i])(Subscript[a, i])]

(*converting the Hopf algebra operations*)
((Subscript[t2b, i])(Subscript[t2b, j]))~(Subscript[B, i,j])~(Subscript[tdm, i,j->k])~(Subscript[B, k])~(Subscript[b2t, k])
(Subscript[t2b, i])~(Subscript[B, i])~(Subscript[tdΔ, i->j,k])~(Subscript[B, j,k])~((Subscript[b2t, j])(Subscript[b2t, k]))/.𝕖->E
(Subscript[t2b, i])~(Subscript[B, i])~(Subscript[tdS, i])~(Subscript[B, i])~(Subscript[b2t, i])

(Subscript[dm, i_,j_->k_]):=𝔼[(Subscript[a, k]) (Subscript[α, i])+(Subscript[a, k]) (Subscript[α, j])+(Subscript[t, k]) (Subscript[τ, i])+(Subscript[t, k]) (Subscript[τ, j]),(E^(-(Subscript[α, i])-(Subscript[α, j]))) ((E^((Subscript[α, i])+(Subscript[α, j]))) (Subscript[y, k]) (Subscript[η, i])+(E^(Subscript[α, j])) (Subscript[y, k]) (Subscript[η, j])+(E^(Subscript[α, i])) (Subscript[x, k]) (Subscript[ξ, i])+(E^((Subscript[α, i])+(Subscript[α, j]))) (Subscript[η, j]) (Subscript[ξ, i])-(E^((Subscript[t, k])+(Subscript[α, i])+(Subscript[α, j]))) (Subscript[η, j]) (Subscript[ξ, i])+(E^((Subscript[α, i])+(Subscript[α, j]))) (Subscript[x, k]) (Subscript[ξ, j])),(1/4) (E^(-(Subscript[α, i])-(Subscript[α, j]))) (4 (E^((Subscript[α, i])+(Subscript[α, j])))+8 (E^((Subscript[t, k])+(Subscript[α, i])+(Subscript[α, j]))) ϵ (Subscript[a, k]) (Subscript[η, j]) (Subscript[ξ, i])+4 ϵ (Subscript[x, k]) (Subscript[y, k]) (Subscript[η, j]) (Subscript[ξ, i])+2 (E^(Subscript[α, j])) ϵ (Subscript[y, k]) (Subscript[η, j]^2) (Subscript[ξ, i])-6 (E^((Subscript[t, k])+(Subscript[α, j]))) ϵ (Subscript[y, k]) (Subscript[η, j]^2) (Subscript[ξ, i])+2 (E^(Subscript[α, i])) ϵ (Subscript[x, k]) (Subscript[η, j]) (Subscript[ξ, i]^2)-6 (E^((Subscript[t, k])+(Subscript[α, i]))) ϵ (Subscript[x, k]) (Subscript[η, j]) (Subscript[ξ, i]^2)+(E^((Subscript[α, i])+(Subscript[α, j]))) ϵ (Subscript[η, j]^2) (Subscript[ξ, i]^2)-4 (E^((Subscript[t, k])+(Subscript[α, i])+(Subscript[α, j]))) ϵ (Subscript[η, j]^2) (Subscript[ξ, i]^2)+3 (E^(2 (Subscript[t, k])+(Subscript[α, i])+(Subscript[α, j]))) ϵ (Subscript[η, j]^2) (Subscript[ξ, i]^2))]
(Subscript[dΔ, i_->j_,k_]):=𝔼[(Subscript[a, j]) (Subscript[α, i])+(Subscript[a, k]) (Subscript[α, i])+(Subscript[t, j]) (Subscript[τ, i])+(Subscript[t, k]) (Subscript[τ, i]),(Subscript[y, j]) (Subscript[η, i])+(E^(Subscript[t, j])) (Subscript[y, k]) (Subscript[η, i])+(Subscript[x, j]) (Subscript[ξ, i])+(Subscript[x, k]) (Subscript[ξ, i]),(1/2) (2-2 (E^(Subscript[t, j])) ϵ (Subscript[a, j]) (Subscript[y, k]) (Subscript[η, i])+(E^(Subscript[t, j])) ϵ (Subscript[y, j]) (Subscript[y, k]) (Subscript[η, i]^2)-2 ϵ (Subscript[a, j]) (Subscript[x, k]) (Subscript[ξ, i])+ϵ (Subscript[x, j]) (Subscript[x, k]) (Subscript[ξ, i]^2))]
(Subscript[dS, i_]):=𝔼[-(Subscript[a, i]) (Subscript[α, i])-(Subscript[t, i]) (Subscript[τ, i]),(E^(-(Subscript[t, i]))) (-(E^(Subscript[α, i])) (Subscript[y, i]) (Subscript[η, i])-(E^((Subscript[t, i])+(Subscript[α, i]))) (Subscript[x, i]) (Subscript[ξ, i])+(E^(Subscript[α, i])) (Subscript[η, i]) (Subscript[ξ, i])-(E^((Subscript[t, i])+(Subscript[α, i]))) (Subscript[η, i]) (Subscript[ξ, i])),(1/4) (E^(-2 (Subscript[t, i]))) (4 (E^(2 (Subscript[t, i])))+4 (E^((Subscript[t, i])+(Subscript[α, i]))) ϵ (Subscript[y, i]) (Subscript[η, i])-4 (E^((Subscript[t, i])+(Subscript[α, i]))) ϵ (Subscript[a, i]) (Subscript[y, i]) (Subscript[η, i])-2 (E^(2 (Subscript[α, i]))) ϵ (Subscript[y, i]^2) (Subscript[η, i]^2)-4 (E^(2 (Subscript[t, i])+(Subscript[α, i]))) ϵ (Subscript[a, i]) (Subscript[x, i]) (Subscript[ξ, i])-4 (E^((Subscript[t, i])+(Subscript[α, i]))) ϵ (Subscript[η, i]) (Subscript[ξ, i])+4 (E^(2 (Subscript[t, i])+(Subscript[α, i]))) ϵ (Subscript[η, i]) (Subscript[ξ, i])+8 (E^((Subscript[t, i])+(Subscript[α, i]))) ϵ (Subscript[a, i]) (Subscript[η, i]) (Subscript[ξ, i])-4 (E^((Subscript[t, i])+2 (Subscript[α, i]))) ϵ (Subscript[x, i]) (Subscript[y, i]) (Subscript[η, i]) (Subscript[ξ, i])+6 (E^(2 (Subscript[α, i]))) ϵ (Subscript[y, i]) (Subscript[η, i]^2) (Subscript[ξ, i])-2 (E^((Subscript[t, i])+2 (Subscript[α, i]))) ϵ (Subscript[y, i]) (Subscript[η, i]^2) (Subscript[ξ, i])-2 (E^(2 (Subscript[t, i])+2 (Subscript[α, i]))) ϵ (Subscript[x, i]^2) (Subscript[ξ, i]^2)+6 (E^((Subscript[t, i])+2 (Subscript[α, i]))) ϵ (Subscript[x, i]) (Subscript[η, i]) (Subscript[ξ, i]^2)-2 (E^(2 (Subscript[t, i])+2 (Subscript[α, i]))) ϵ (Subscript[x, i]) (Subscript[η, i]) (Subscript[ξ, i]^2)-3 (E^(2 (Subscript[α, i]))) ϵ (Subscript[η, i]^2) (Subscript[ξ, i]^2)+4 (E^((Subscript[t, i])+2 (Subscript[α, i]))) ϵ (Subscript[η, i]^2) (Subscript[ξ, i]^2)-(E^(2 (Subscript[t, i])+2 (Subscript[α, i]))) ϵ (Subscript[η, i]^2) (Subscript[ξ, i]^2))]

Does it match the m-tensor from SLPortfolioProgram.nb? They do match on the generators?

{
" [t,y] = "        ((𝔼[0,0,(Subscript[y, 2])(Subscript[t, 1])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[y, 1])(Subscript[t, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]),
" [t,a] = "        ((𝔼[0,0,(Subscript[a, 2])(Subscript[t, 1])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[a, 1])(Subscript[t, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]),
" [t,x] = "        ((𝔼[0,0,(Subscript[x, 2])(Subscript[t, 1])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[x, 1])(Subscript[t, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]),
" [a,y] = "        ((𝔼[0,0,(Subscript[y, 2])(Subscript[a, 1])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[y, 1])(Subscript[a, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]),
" [x,a] = "        ((𝔼[0,0,(Subscript[a, 2])(Subscript[x, 1])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[a, 1])(Subscript[x, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]),
" xy - qyx = "((𝔼[0,0,(Subscript[x, 1])(Subscript[y, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]-(1+ϵ)(𝔼[0,0,(Subscript[y, 1])(Subscript[x, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]])
}/.{(Subscript[z_, 1])->z,𝕖->E}//Expand//Factor
{
" Δ(a) = "((𝔼[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2]))[[3]]),
" Δ(x) = "((𝔼[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2]))[[3]]),
" Δ(t) = "((𝔼[0,0,(Subscript[t, 1])]~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2]))[[3]]),
" Δ(y) = "((𝔼[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2]))[[3]])
}/.{𝕖->E}//Simplify
{
" S(a) = "((𝔼[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[dS, 1]))[[3]]),
" S(x) = "((𝔼[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[dS, 1]))[[3]]),
" S(t) = "((𝔼[0,0,(Subscript[t, 1])]~(Subscript[B, 1])~(Subscript[dS, 1]))[[3]]),
" S(y) = "((𝔼[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[dS, 1]))[[3]])
}/.{(Subscript[z_, 1])->z,𝕖->E}//Simplify

Hopf algebra axioms on double

(co)-associativity

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

Δ is an algebra morphism

(Subscript[dm, 1,2->1])~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2])≡((Subscript[dΔ, 1->1,3])(Subscript[dΔ, 2->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[dm, 3,4->2])(Subscript[dm, 1,2->1]))/.𝕖->E//Timing

S is convolution inverse of id

{((Subscript[dΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[dS, 1]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]),((Subscript[dΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[dS, 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])}/.𝕖->E//Timing

S is a (co)-algebra anti-morphism

{(Subscript[dm, 1,2->1])~(Subscript[B, 1])~(Subscript[dS, 1])≡((Subscript[dS, 1])(Subscript[dS, 2]))~(Subscript[B, 1,2])~(Subscript[dm, 2,1->1]),(Subscript[dS, 1])~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2])≡(Subscript[dΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[dS, 1])(Subscript[dS, 2]))}/.𝕖->E//Expand//Timing

R-matrix

(Subscript[tR, i,j])~(Subscript[B, i,j])~((Subscript[b2t, i])(Subscript[b2t, j]))
(Subscript[(OverBar[tR]), i,j])~(Subscript[B, i,j])~((Subscript[b2t, i])(Subscript[b2t, j]))

(*Deriving (OverBar[R]) formula*)
Expand/@(Subscript[R, i,j])~(Subscript[B, j])~(Subscript[dS, j])

(Subscript[R, i_,j_]):=𝔼[-(Subscript[a, j]) (Subscript[t, i]),(Subscript[x, j]) (Subscript[y, i]),(1/4) (4+4 ϵ (Subscript[a, i]) (Subscript[a, j])-ϵ (Subscript[x, j]^2) (Subscript[y, i]^2))]
(Subscript[(OverBar[R]), i_,j_]):=𝔼[(Subscript[a, j]) (Subscript[t, i]),-(E^(-(Subscript[t, i]))) (Subscript[x, j]) (Subscript[y, i]),(1/4) (E^(-2 (Subscript[t, i]))) (4 (E^(2 (Subscript[t, i])))-4 (E^(2 (Subscript[t, i]))) ϵ (Subscript[a, i]) (Subscript[a, j])-4 (E^(Subscript[t, i])) ϵ (Subscript[a, i]) (Subscript[x, j]) (Subscript[y, i])-4 (E^(Subscript[t, i])) ϵ (Subscript[a, j]) (Subscript[x, j]) (Subscript[y, i])-3 ϵ (Subscript[x, j]^2) (Subscript[y, i]^2))]

Quasi-triangular axiom 1:

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

Quasi-triangular axiom 2:

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

Reidemeister 3:

(((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6]))~(Subscript[B, 1,4])~(Subscript[dm, 1,4->1])~(Subscript[B, 2,5])~(Subscript[dm, 2,5->2])~(Subscript[B, 3,6])~(Subscript[dm, 3,6->3]) ≡
((Subscript[R, 1,6])(Subscript[R, 2,3])(Subscript[R, 4,5]))~(Subscript[B, 1,4])~(Subscript[dm, 1,4->1])~(Subscript[B, 2,5])~(Subscript[dm, 2,5->2])~(Subscript[B, 3,6])~(Subscript[dm, 3,6->3]))/.𝕖->E//Timing

Deriving the Drinfeld element u and its inverse ui

(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])

{(Subscript[u, 1]),(Subscript[ui, 1])}

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])

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])).

(Subscript[CC, i_]):=𝔼[0,0,(𝕖^( (1/2) (Subscript[t, i])))(1-ϵ (Subscript[a, i]))]
(Subscript[(OverBar[CC]), i_]):=𝔼[0,0,(𝕖^( ((-1)/2) (Subscript[t, i])))(1+ϵ (Subscript[a, i]))]

Kinks

k1=((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])/.𝕖->E;
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;
k3=((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])/.𝕖->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;
{k1≡k2,k3≡k4,(k1 k3)~(Subscript[B, i,j])~(Subscript[dm, i,j->1])}
k1
k3

(Subscript[Kink, i_]):=𝔼[-(Subscript[a, i]) (Subscript[t, i]),(Subscript[x, i]) (Subscript[y, i]),(1/4) (E^(-((Subscript[t, i])/2))) (4+4 ϵ (Subscript[a, i])+4 ϵ (Subscript[a, i]^2)-ϵ (Subscript[x, i]^2) (Subscript[y, i]^2))]
(Subscript[(OverBar[Kink]), j_]):=𝔼[(Subscript[a, j]) (Subscript[t, j]),-(E^(-(Subscript[t, j]))) (Subscript[x, j]) (Subscript[y, j]),(1/4) (E^(-2 (Subscript[t, j]))) (4 (E^((5 (Subscript[t, j]))/2))-4 (E^((5 (Subscript[t, j]))/2)) ϵ (Subscript[a, j])-4 (E^((5 (Subscript[t, j]))/2)) ϵ (Subscript[a, j]^2)-8 (E^((3 (Subscript[t, j]))/2)) ϵ (Subscript[a, j]) (Subscript[x, j]) (Subscript[y, j])-3 (E^((Subscript[t, j])/2)) ϵ (Subscript[x, j]^2) (Subscript[y, j]^2))]

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

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])/.𝕖->E,{r,2,10}]//Timing
Z
1/(Z[[3]]/.(𝕖^(c_. (Subscript[t, 1])))->(T^c))//Expand

1/Z[[3]]/.{(E^(c_. (Subscript[t, 1])))->(T^c),ϵ->0}//Factor//Expand
Coefficient[Z[[3]]/.(E^(c_. (Subscript[t, 1])))->(T^c),ϵ]//Factor

Z[[3]]/.(E^(c_. (Subscript[t, 1])))->(T^c)//Factor