Pensieve header: The “Speedy” engine.

(Subscript[PP, _])=Identity; $k=1;γ=1;ℏ=1;

The “Speedy” Engine

Internal Utilities

Canonical Form:

CCF[ℰ_] := (Subscript[PP, CCF])@ExpandDenominator@ExpandNumerator@(Subscript[PP, Together])@Together[(Subscript[PP, Exp])[
Expand[ℰ] //. (E^(x_))(E^(y_)):>(E^(x+y)) /. (E^(x_)):>(E^(CCF[x]))]];
CF[ℰ_List]:=CF/@ℰ;
CF[sd_SeriesData] := MapAt[CF,sd,3];
CF[ℰ_] := (Subscript[PP, CF])@Module[
{vs=Cases[ℰ,(Subscript[(y|b|t|a|x|η|β|τ|α|ξ), _]),∞]⋃{y,b,t,a,x,η,β,τ,α,ξ}},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))]
];
CF[ℰ_𝔼]:=CF/@ℰ; CF[(Subscript[𝔼, sp___])[ℰs___]]:=CF/@(Subscript[𝔼, sp])[ℰs];

The Kronecker δ:

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

Equality, multiplication, and degree-adjustment 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];
(Subscript[𝔼[L_,Q_,P_], $k_]):=𝔼[L,Q,Series[Normal@P,{ϵ,0,$k}]];

Zip and Bind

Variables and their duals:

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

Upper to lower and lower to Upper:

U2l={(Subscript[B, i_]^(p_.)):>(E^(-p ℏ γ (Subscript[b, i]))),(B^(p_.)):>(E^(-p ℏ γ b)), (Subscript[T, i_]^(p_.)):>(E^(-p ℏ (Subscript[t, i]))),(T^(p_.)):>(E^(-p ℏ t)),(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[t, i_])+d_.)):>(Subscript[T, i]^(-c/ℏ))(E^d),(E^(c_.t+d_.)):>(T^(-c/ℏ))(E^d),
(E^(c_.(Subscript[α, i_])+d_.)):>(Subscript[𝒜, i]^(c/γ))(E^d),(E^(c_.α+d_.)):>(𝒜^(c/γ))(E^d),
(E^(ℰ_)):>(E^(Expand@ℰ))};

Derivatives in the presence of exponentiated variables:

(Subscript[D, b])[f_]:=(∂_b)f-ℏ γ B(∂_B)f; (Subscript[D, (Subscript[b, i_])])[f_]:=(∂_(Subscript[b, i]))f-ℏ γ (Subscript[B, i])(∂_(Subscript[B, i]))f;
(Subscript[D, t])[f_]:=(∂_t)f+ℏ T(∂_T)f; (Subscript[D, (Subscript[t, i_])])[f_]:=(∂_(Subscript[t, i]))f+ℏ (Subscript[T, i])(∂_(Subscript[T, i]))f; 
(Subscript[D, α])[f_]:=(∂_α)f+γ 𝒜 (∂_𝒜)f; (Subscript[D, (Subscript[α, i_])])[f_]:=(∂_(Subscript[α, i]))f+γ (Subscript[𝒜, i]) (∂_(Subscript[𝒜, i]))f;
(Subscript[D, v_])[f_]:=(∂_v)f; (Subscript[D, {v_,0}])[f_]:=f; (Subscript[D, {}])[f_]:=f; (Subscript[D, {v_,n_Integer}])[f_]:=(Subscript[D, v])[(Subscript[D, {v,n-1}])[f]];
(Subscript[D, {l_List,ls___}])[f_]:=(Subscript[D, {ls}])[(Subscript[D, l])[f]];

Finite Zips:

collect[sd_SeriesData, ζ_] := MapAt[collect[#,ζ]&,sd,3];
collect[ℰ_,ζ_] := (Subscript[PP, Collect])@Collect[ℰ,ζ];
(Subscript[Zip, {}])[P_]:=P;
(Subscript[Zip, ζs_])[Ps_List]:=(Subscript[Zip, ζs])/@Ps;
(Subscript[Zip, {ζ_,ζs___}])[P_] := (Subscript[PP, Zip])[
(collect[P//(Subscript[Zip, {ζs}]),ζ] /. f_.(ζ^(d_.)):>((Subscript[D, {(SuperStar[ζ]),d}])[f]))/.(SuperStar[ζ])->0/.(((SuperStar[ζ])/.{b->B,t->T,α->𝒜})->1)]

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

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

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])@𝔼[L_,Q_,P_] := (Subscript[PP, LZip])@Module[{ζ,z,zs,Zs,c,ys,ηs,lt,zrule,Zrule,ζrule,Q1,EEQ,EQ},
zs=Table[(SuperStar[ζ]),{ζ,ζs}];
Zs=zs/.{b->B,t->T,α->𝒜};
c=L/.Alternatives@@(ζs⋃zs)->0/.Alternatives@@Zs->1;
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)];
Zrule=Join[zrule,zrule/.r_Rule:>((U=r[[1]]/.{b->B,t->T,α->𝒜})->(U/.U2l/.r//.l2U))];
ζrule=Thread[ζs->ζs+ηs.lt];
Q1=Q/.(Zrule⋃ζrule);
EEQ[ps___]:=EEQ[ps]=(Subscript[PP, "EEQ"])@(CF[(E^(-Q1))(Subscript[D, Thread[{zs,{ps}}]])[(E^Q1)]]/.{Alternatives@@zs->0,Alternatives@@Zs->1});
CF@𝔼[c+ηs.lt.ys,Q1/.{Alternatives@@zs->0,Alternatives@@Zs->1},
Det[lt]((Subscript[Zip, ζs])[(EQ@@zs)(P/.(Zrule⋃ζrule))] /. Derivative[ps___][EQ][___] :> EEQ[ps] /. _EQ->1)  ] ];

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

𝔼 morphisms with domain and range.

(Subscript[B, is_List])[(Subscript[𝔼, d1_->r1_])[L1_,Q1_,P1_],(Subscript[𝔼, d2_->r2_])[L2_,Q2_,P2_]]:=(Subscript[𝔼, (d1⋃Complement[d2,is])->(r2⋃Complement[r1,is])])@@(Subscript[B, is])[𝔼[L1,Q1,P1],𝔼[L2,Q2,P2]];
(Subscript[𝔼, d1_->r1_])[L1_,Q1_,P1_]//(Subscript[𝔼, d2_->r2_])[L2_,Q2_,P2_] := (Subscript[B, r1⋂d2])[(Subscript[𝔼, d1->r1])[L1,Q1,P1],(Subscript[𝔼, d2->r2])[L2,Q2,P2]];
(Subscript[𝔼, d1_->r1_])[L1_,Q1_,P1_]≡(Subscript[𝔼, d2_->r2_])[L2_,Q2_,P2_] ^:= (d1==d2)∧(r1==r2)∧(𝔼[L1,Q1,P1]≡𝔼[L2,Q2,P2]);
(Subscript[𝔼, d1_->r1_])[L1_,Q1_,P1_](Subscript[𝔼, d2_->r2_])[L2_,Q2_,P2_] ^:= (Subscript[𝔼, (d1⋃d2)->(r1⋃r2)])@@(𝔼[L1,Q1,P1]𝔼[L2,Q2,P2]);
(Subscript[(Subscript[𝔼, dr_])[L_,Q_,P_], $k_]):=(Subscript[𝔼, dr])@@(Subscript[𝔼[L,Q,P], $k]);
(Subscript[𝔼, _])[ℰ___][i_]:={ℰ}[[i]];

𝔼[Λ]

(Subscript[𝔼, dr_])[Λ_]:=CF@Module[{L,Λ0=Limit[Λ,ϵ->0]},(Subscript[(Subscript[𝔼, dr])[L=Λ0 /. (Subscript[(η|y|ξ|x), _])->0,Λ0-L,(E^(Λ-Λ0))], $k])/.l2U]

Exponentials as needed.

Task. Define  (Subscript[Exp, m,i,k])[P] to compute (e^(𝕆(P))) to (ϵ^k) in the using the (Subscript[m, i,i->i]) multiplication, where P is an ϵ-dependent near-docile element, giving the answer in 𝔼-form.
Methodology. If (Subscript[P, 0]):=(Subscript[P, ϵ=0]) and (e^(λ 𝕆(P)))=𝕆((e^(λ (Subscript[P, 0])))F(λ)), then F(λ=0)=1 and we have:
𝕆((e^(λ (Subscript[P, 0])))((Subscript[P, 0])F(λ)+(∂_λ)F))=𝕆((∂_λ)(e^(λ (Subscript[P, 0])))F(λ))=(∂_λ)𝕆((e^(λ (Subscript[P, 0])))F(λ))=(∂_λ)(e^(λ 𝕆(P)))=(e^(λ 𝕆(P)))𝕆(P)=𝕆((e^(λ (Subscript[P, 0])))F(λ))𝕆(P).
This is a linear ODE for F. Setting inductively (Subscript[F, k])=(Subscript[F, k-1])+(ϵ^k)φ we find that (Subscript[F, 0])=1 and solve for φ.

(* Bug: The first line is valid only if 𝕆((E^(Subscript[P, 0])))==(E^(𝕆((Subscript[P, 0])))). *)
(Subscript[Exp, m_,i_,0])[P_]:=Module[{LQ=Normal@P /. ϵ->0},
𝔼[LQ/.(Subscript[(x|y), i])->0, LQ/.(Subscript[(b|a|t), i])->0,1] ];

(Subscript[Exp, m_,i_,k_])[P_]:=Block[{$k=k},
Module[{P0,λ,φ,φs,F,j,rhs,eqn,pows,at0,atλ},
P0=Normal@P /. ϵ->0;
F=Normal@Last@(Subscript[Exp, m,i,k-1])[λ P];
While[
rhs=(Subscript[m, i,j->i])[(Subscript[(Subscript[𝔼, {}->{i}])[λ P0/.(Subscript[(x|y), i])->0,λ P0/.(Subscript[(b|a|t), i])->0, F], k])(Subscript[sσ, i->j])@(Subscript[(Subscript[𝔼, {}->{i}])[0,0,P], k])]//Last//Normal;
eqn=CF[((∂_λ)F)+P0 F-rhs];
eqn=!=0,(*do*)
pows=First/@CoefficientRules[eqn,{(Subscript[y, i]),(Subscript[b, i]),(Subscript[a, i]),(Subscript[x, i])}];
F+=Sum[(ϵ^k)(Subscript[φ, js])[λ]Times@@(({(Subscript[y, i]),(Subscript[b, i]),(Subscript[a, i]),(Subscript[x, i])})^js),{js,pows}];
rhs=(Subscript[m, i,j->i])[(Subscript[(Subscript[𝔼, {}->{i}])[λ P0/.(Subscript[(x|y), i])->0,λ P0/.(Subscript[(b|a|t), i])->0, F], k])(Subscript[sσ, i->j])@(Subscript[(Subscript[𝔼, {}->{i}])[0,0,P], k])]//Last//Normal;
eqn=CF[((∂_λ)F)+P0 F-rhs];
φs=Table[(Subscript[φ, js])[λ],{js,pows}];
at0=Table[(Subscript[φ, js])[0]==0,{js,pows}];
atλ=(#==0)&/@(pows/.CoefficientRules[eqn,{(Subscript[y, i]),(Subscript[b, i]),(Subscript[a, i]),(Subscript[x, i])}]);
F=F/. DSolve[And@@(at0⋃atλ),φs,λ][[1]]
];
(Subscript[𝔼, {}->{i}])[P0/.(Subscript[(x|y), i])->0,P0/.(Subscript[(b|a|t), i])->0, F+((O[ϵ])^(k+1))/.λ->1]] ]

“Define” Code

Define[lhs=rhs, ...] defines the lhs to be rhs, except that rhs is computed only once for each value of $k. Fancy Mathematica not for the faint of heart. Most readers should ignore.

SetAttributes[Define, HoldAll];
Define[def_,defs__] := (Define[def]; Define[defs];);
Define[(Subscript[op_, is__])=ℰ_] := Module[{SD,ii,jj,kk,isp,nis,nisp,sis},Block[{i,j,k},
ReleaseHold[Hold[
SD[(Subscript[op, nisp,$k_Integer]),(Subscript[PP, Boot])@Block[{i,j,k},(Subscript[op, isp,$k])=ℰ;(Subscript[op, nis,$k])]];
SD[(Subscript[op, isp]),(Subscript[op, {is},$k])]; SD[(Subscript[op, sis__]),(Subscript[op, {sis}])];
]/. {SD->SetDelayed,
isp->{is}/.{i->i_,j->j_,k->k_},
nis->{is}/.{i->ii,j->jj,k->kk},
nisp->{is}/.{i->ii_,j->jj_,k->kk_}
}]  ]]

The Objects

Symmetric Algebra Objects

(Subscript[sm, i_,j_->k_]):=(Subscript[𝔼, {i,j}->{k}])[(Subscript[b, k])((Subscript[β, i])+(Subscript[β, j]))+(Subscript[t, k])((Subscript[τ, i])+(Subscript[τ, j]))+(Subscript[a, k])((Subscript[α, i])+(Subscript[α, j]))+(Subscript[y, k])((Subscript[η, i])+(Subscript[η, j]))+(Subscript[x, k])((Subscript[ξ, i])+(Subscript[ξ, j]))];
(Subscript[sΔ, i_->j_,k_]):=(Subscript[𝔼, {i}->{j,k}])[(Subscript[β, i])((Subscript[b, j])+(Subscript[b, k]))+(Subscript[τ, i])((Subscript[t, j])+(Subscript[t, k]))+(Subscript[α, i])((Subscript[a, j])+(Subscript[a, k]))+(Subscript[η, i])((Subscript[y, j])+(Subscript[y, k]))+(Subscript[ξ, i])((Subscript[x, j])+(Subscript[x, k]))];
(Subscript[sS, i_]):=(Subscript[𝔼, {i}->{i}])[-(Subscript[β, i])(Subscript[b, i])-(Subscript[τ, i])(Subscript[t, i])-(Subscript[α, i])(Subscript[a, i])-(Subscript[η, i])(Subscript[y, i])-(Subscript[ξ, i])(Subscript[x, i])];
(Subscript[sϵ, i_]):=(Subscript[𝔼, {}->{i}])[0];(Subscript[sη, i_]):=(Subscript[𝔼, {i}->{}])[0];

(Subscript[sσ, i_->j_]):=(Subscript[𝔼, {i}->{j}])[(Subscript[β, i])(Subscript[b, j])+(Subscript[τ, i])(Subscript[t, j])+(Subscript[α, i])(Subscript[a, j])+(Subscript[η, i])(Subscript[y, j])+(Subscript[ξ, i])(Subscript[x, j])];
(Subscript[sΥ, i_->j_,k_,l_,m_]):=(Subscript[𝔼, {i}->{j,k,l,m}])[(Subscript[β, i])(Subscript[b, k])+(Subscript[τ, i])(Subscript[t, k])+(Subscript[α, i])(Subscript[a, l])+(Subscript[η, i])(Subscript[y, j])+(Subscript[ξ, i])(Subscript[x, m])];

The CU Definitions

cΛ=((Subscript[η, i])+(((E^(-γ (Subscript[α, i])-ϵ (Subscript[β, i]))) (Subscript[η, j]))/(1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i]))))(Subscript[y, k])+((Subscript[β, i])+(Subscript[β, j])+((Log[1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i])])/ϵ))(Subscript[b, k])+((Subscript[α, i])+(Subscript[α, j])+((Log[1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i])])/γ))(Subscript[a, k])+((((E^(-γ (Subscript[α, j])-ϵ (Subscript[β, j]))) (Subscript[ξ, i]))/(1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i])))+(Subscript[ξ, j]))(Subscript[x, k]);
Define[(Subscript[cm, i,j->k])=(Subscript[𝔼, {i,j}->{k}])[cΛ]]

Define[(Subscript[cσ, i->j])=(Subscript[sσ, i,j])/.(Subscript[τ, i])->0,(Subscript[cϵ, i])=(Subscript[sϵ, i]), (Subscript[cη, i])=(Subscript[sη, i]),(Subscript[cΔ, i->j,k])=(Subscript[sΔ, i->j,k]),
(Subscript[cS, i])=(Subscript[sS, i])//(Subscript[sΥ, i->1,2,3,4])//(Subscript[cm, 4,3->i])//(Subscript[cm, i,2->i])//(Subscript[cm, i,1->i])];

Booting Up QU

Define[(Subscript[aσ, i->j])=(Subscript[𝔼, {i}->{j}])[(Subscript[a, j]) (Subscript[α, i])+(Subscript[x, j]) (Subscript[ξ, i])],(Subscript[bσ, i->j])=(Subscript[𝔼, {i}->{j}])[(Subscript[b, j]) (Subscript[β, i])+(Subscript[y, j]) (Subscript[η, i])]]

Define[(Subscript[am, i,j->k])=(Subscript[𝔼, {i,j}->{k}])[((Subscript[α, i])+(Subscript[α, j]))(Subscript[a, k])+((Subscript[𝒜, j]^(-1))(Subscript[ξ, i])+(Subscript[ξ, j]))(Subscript[x, k])],
(Subscript[bm, i,j->k])=(Subscript[𝔼, {i,j}->{k}])[((Subscript[β, i])+(Subscript[β, j]))(Subscript[b, k])+((Subscript[η, i])+(E^(- ϵ (Subscript[β, i])))(Subscript[η, j]))(Subscript[y, k])]]

Three types of inverses appear below!
(OverBar[R]) is the inverse of R in the algebra 𝔹⊗𝔸.
P is the inverse of R as a quadratic form, like how an element of (SuperStar[V])⊗(SuperStar[V]) can be the inverse of an element of V⊗V.
(OverBar[aS]) is the inverse of aS as an operator form, like how an element of (SuperStar[V])⊗V can be the inverse of another element of (SuperStar[V])⊗V.

Define[(Subscript[R, i,j])=(Subscript[𝔼, {}->{i,j}])[ℏ (Subscript[a, j]) (Subscript[b, i])+(∑_(k=1)^($k+1)) (((((1-(E^(γ ϵ ℏ))))^k)(((ℏ (Subscript[y, i])(Subscript[x, j])))^k))/(k(1-(E^(k γ ϵ ℏ)))))],
(Subscript[(OverBar[R]), i,j])=CF@(Subscript[𝔼, {}->{i,j}])[-ℏ (Subscript[a, j]) (Subscript[b, i]),-ℏ (Subscript[x, j]) (Subscript[y, i])/(Subscript[B, i]),1+If[$k==0, 0,(Subscript[((Subscript[(OverBar[R]), {i,j},$k-1])), $k])[3]-
(((Subscript[((Subscript[(OverBar[R]), {i,j},0])), $k])(Subscript[R, 1,2])(Subscript[((Subscript[(OverBar[R]), {3,4},$k-1])), $k]))//((Subscript[bm, i,1->i])(Subscript[am, j,2->j]))//((Subscript[bm, i,3->i])(Subscript[am, j,4->j])))[3]]],
(Subscript[P, i,j])=(Subscript[𝔼, {i,j}->{}])[(Subscript[β, i])(Subscript[α, j])/ℏ,(Subscript[η, i])(Subscript[ξ, j])/ℏ,1+If[$k==0,0,(Subscript[((Subscript[P, {i,j},$k-1])), $k])[3]-
((Subscript[R, 1,2])//((Subscript[((Subscript[P, {1,j},0])), $k])(Subscript[((Subscript[P, {i,2},$k-1])), $k])))[3]]]]

Define[(Subscript[aS, i])=((Subscript[aσ, i->2])(Subscript[(OverBar[R]), 1,i]))//(Subscript[P, 1,2]),
(Subscript[(OverBar[aS]), i])=(Subscript[𝔼, {i}->{i}])[-(Subscript[a, i]) (Subscript[α, i]),-(Subscript[x, i]) (Subscript[𝒜, i]) (Subscript[ξ, i]),1+If[$k==0, 0,(Subscript[((Subscript[(OverBar[aS]), {i},$k-1])), $k])[3]-
((Subscript[((Subscript[(OverBar[aS]), {i},0])), $k])//(Subscript[aS, i])//(Subscript[((Subscript[(OverBar[aS]), {i},$k-1])), $k]))[3]]]]

(was (Subscript[aS, j])=(Subscript[(OverBar[R]), i,j])~(Subscript[B, i])~(Subscript[P, i,j])).

Define[(Subscript[bS, i])=(Subscript[bσ, i->1])(Subscript[R, i,2])//(Subscript[aS, 2])//(Subscript[P, 1,2]),
(Subscript[(OverBar[bS]), i])=(Subscript[bσ, i->1])(Subscript[R, i,2])//(Subscript[(OverBar[aS]), 2])//(Subscript[P, 1,2]),
(Subscript[aΔ, i->j,k])=((Subscript[R, 1,j])(Subscript[R, 2,k]))//(Subscript[bm, 1,2->3])//(Subscript[P, 3,i]),
(Subscript[bΔ, i->j,k])=((Subscript[R, j,1])(Subscript[R, k,2]))//(Subscript[am, 1,2->3])//(Subscript[P, i,3])]

(was (Subscript[bS, i])=(Subscript[R, i,1])~(Subscript[B, 1])~(Subscript[aS, 1])~(Subscript[B, 1])~(Subscript[P, i,1]),(Subscript[(OverBar[bS]), i])=(Subscript[R, i,1])~(Subscript[B, 1])~(Subscript[(OverBar[aS]), 1])~(Subscript[B, 1])~(Subscript[P, i,1])).

The Drinfel’d double:

Define[(Subscript[dm, i,j->k])=(((Subscript[sΥ, i->4,4,1,1])//(Subscript[aΔ, 1->1,2])//(Subscript[aΔ, 2->2,3])//(Subscript[(OverBar[aS]), 3]))((Subscript[sΥ, j->-1,-1,-4,-4])//(Subscript[bΔ, -1->-1,-2])//(Subscript[bΔ, -2->-2,-3])))//((Subscript[P, -1,3])(Subscript[P, -3,1])(Subscript[am, 2,-4->k])(Subscript[bm, 4,-2->k]))]

Define[(Subscript[dσ, i->j])=(Subscript[aσ, i->j])(Subscript[bσ, i->j]),
(Subscript[dϵ, i])=(Subscript[sϵ, i]), (Subscript[dη, i])=(Subscript[sη, i]),
(Subscript[dS, i])=(Subscript[sΥ, i->1,1,2,2])//((Subscript[(OverBar[bS]), 1])(Subscript[aS, 2]))//(Subscript[dm, 2,1->i]),
(Subscript[(OverBar[dS]), i])=(Subscript[sΥ, i->1,1,2,2])//((Subscript[bS, 1])(Subscript[(OverBar[aS]), 2]))//(Subscript[dm, 2,1->i]),
(Subscript[dΔ, i->j,k])=((Subscript[bΔ, i->3,1])(Subscript[aΔ, i->2,4]))//((Subscript[dm, 3,4->k])(Subscript[dm, 1,2->j]))]

Define[(Subscript[C, i])=(Subscript[(Subscript[𝔼, {}->{i}])[0,0,(Subscript[B, i]^(1/2))(E^(-ℏ ϵ (Subscript[a, i])/2))], $k]),
(Subscript[(OverBar[C]), i])=(Subscript[(Subscript[𝔼, {}->{i}])[0,0,(Subscript[B, i]^(-1/2))(E^(ℏ ϵ (Subscript[a, i])/2))], $k]),
(Subscript[c, i])=(Subscript[(Subscript[𝔼, {}->{i}])[0,0,(Subscript[B, i]^(1/4))(E^(-ℏ ϵ (Subscript[a, i])/4))], $k]),
(Subscript[(OverBar[c]), i])=(Subscript[(Subscript[𝔼, {}->{i}])[0,0,(Subscript[B, i]^(-1/4))(E^(ℏ ϵ (Subscript[a, i])/4))], $k]),
(Subscript[Kink, i]) = ((Subscript[R, 1,3])(Subscript[(OverBar[C]), 2]))//(Subscript[dm, 1,2->1])//(Subscript[dm, 1,3->i]),
(Subscript[(OverBar[Kink]), i]) = ((Subscript[(OverBar[R]), 1,3])(Subscript[C, 2]))//(Subscript[dm, 1,2->1])//(Subscript[dm, 1,3->i]),
(Subscript[ρ, i])=((Subscript[c, 1])(Subscript[(OverBar[c]), 3])(Subscript[dS, i]))//(Subscript[dm, 1,i->i])//(Subscript[dm, i,3->i])](*ρ reverses a strand*)

Note. t==-ϵa+γb and b==t/γ+ϵa/γ previously:t==ϵa-γb and b==-t/γ+ϵa/γ.

Define[(Subscript[b2t, i])=(Subscript[𝔼, {i}->{i}])[(Subscript[α, i])(Subscript[a, i])+(Subscript[β, i])(ϵ (Subscript[a, i])+(Subscript[t, i]))/γ+(Subscript[ξ, i])(Subscript[x, i])+(Subscript[η, i])(Subscript[y, i])],
(Subscript[t2b, i])=(Subscript[𝔼, {i}->{i}])[(Subscript[α, i])(Subscript[a, i])+(Subscript[τ, i])(-ϵ (Subscript[a, i])+γ (Subscript[b, i]))+(Subscript[ξ, i])(Subscript[x, i])+(Subscript[η, i])(Subscript[y, i])]]

The Knot Tensors

Define[(Subscript[kR, i,j])=(Subscript[R, i,j])//((Subscript[b2t, i])(Subscript[b2t, j])) /. (Subscript[t, i|j])->t,
(Subscript[(OverBar[kR]), i,j])=(Subscript[(OverBar[R]), i,j])//((Subscript[b2t, i])(Subscript[b2t, j])) /. {(Subscript[t, i|j])->t,(Subscript[T, i|j])->T},
(Subscript[km, i,j->k])=(((Subscript[t2b, i])(Subscript[t2b, j]))//(Subscript[dm, i,j->k])//(Subscript[b2t, k]) )/. {(Subscript[t, k])->t, (Subscript[T, k])->T,(Subscript[τ, i|j])->0},
(Subscript[kC, i])=((Subscript[C, i])//(Subscript[b2t, i]) )/. (Subscript[T, i])->T,
(Subscript[(OverBar[kC]), i])=((Subscript[(OverBar[C]), i])//(Subscript[b2t, i]) )/. (Subscript[T, i])->T,
(Subscript[kKink, i])=(Subscript[Kink, i])//(Subscript[b2t, i]) /. {(Subscript[t, i])->t, (Subscript[T, i])->T},
(Subscript[(OverBar[kKink]), i])=(Subscript[(OverBar[Kink]), i])//(Subscript[b2t, i]) /. {(Subscript[t, i])->t, (Subscript[T, i])->T}]

Define[(Subscript[BS, i,j->k])=(Subscript[C, 3])(Subscript[C, 4])(Subscript[dΔ, i->l1,r1])(Subscript[dΔ, j->l2,r2])//(Subscript[(OverBar[dS]), r1])//(Subscript[dS, r2])//(Subscript[dm, l1,3->k])//(Subscript[dm, k,r2->k])//(Subscript[dm, k,r1->k])//(Subscript[dm, k,4->k])//(Subscript[dm, k,l2->k])]
Define[(Subscript[tBS, i,j->k])=((Subscript[t2b, i])(Subscript[t2b, j]))//(Subscript[C, 3])(Subscript[C, 4])(Subscript[dΔ, i->l1,r1])(Subscript[dΔ, j->l2,r2])//(Subscript[(OverBar[dS]), r1])//(Subscript[dS, r2])//(Subscript[dm, l1,3->k])//(Subscript[dm, k,r2->k])//(Subscript[dm, k,r1->k])//(Subscript[dm, k,4->k])//(Subscript[dm, k,l2->k])//(Subscript[b2t, k])]
Define[(Subscript[tm, i,j->k])=(Subscript[t2b, i])//(Subscript[t2b, j])//(Subscript[dm, i,j->k])//(Subscript[b2t, k])]
Define[(Subscript[tR, i,j])=(Subscript[R, i,j])//(Subscript[b2t, i])//(Subscript[b2t, j]),(Subscript[(OverBar[tR]), i,j])=(Subscript[(OverBar[R]), i,j])//(Subscript[b2t, i])//(Subscript[b2t, j]),(Subscript[tS, i])=(Subscript[t2b, i])//(Subscript[dS, i])//(Subscript[b2t, i])]
Define[(Subscript[tC, i])=(Subscript[C, i])//(Subscript[b2t, i]) ,(Subscript[(OverBar[tC]), i])=(Subscript[(OverBar[C]), i])//(Subscript[b2t, i]) ]
Define[(Subscript[tKink, i])=(Subscript[Kink, i])//(Subscript[b2t, i]) ,(Subscript[(OverBar[tKink]), i])=(Subscript[(OverBar[Kink]), i])//(Subscript[b2t, i])]

Example tangle G is two positive kinks.

G=((Subscript[tKink, 1])(Subscript[tKink, 4])(Subscript[(OverBar[tR]), 2,3]))//(Subscript[tm, 1,3->i])//(Subscript[tm, 2,4->j])

G2 = ((Subscript[tR, 5,1])(Subscript[tC, 3])(Subscript[(OverBar[tR]), 2,7])(Subscript[tR, 8,4])(Subscript[tC, 6]))//(Subscript[tm, 1,3->i])//(Subscript[tm, i,5->i])//(Subscript[tm, i,7->i])//(Subscript[tm, 2,4->j])//(Subscript[tm, j,6->j])//(Subscript[tm, j,8->j])

(Subscript[tm, 1,2->k])/.{(Subscript[t, k])->0,(Subscript[T, k])->1}
((Subscript[tm, 1,2->k])//(Subscript[tm, k,3->k]))/.{(Subscript[t, k])->0,(Subscript[T, k])->1}
((Subscript[tm, 1,2->k])//(Subscript[tm, k,3->k])//(Subscript[tm, k,4->k]))/.{(Subscript[t, k])->0,(Subscript[T, k])->1}
((Subscript[tm, 1,2->k])//(Subscript[tm, k,3->k])//(Subscript[tm, k,4->k])//(Subscript[tm, k,5->k]))/.{(Subscript[t, k])->0,(Subscript[T, k])->1}
((Subscript[tm, 1,2->k])//(Subscript[tm, k,3->k])//(Subscript[tm, k,4->k])//(Subscript[tm, k,5->k]))/.{(Subscript[t, k])->0,(Subscript[T, k])->1,(Subscript[𝒜, _])->1}

(Subscript[tR, i,j])/.{(Subscript[t, i|j])->0,(Subscript[T, i|j])->1}
(Subscript[(OverBar[tR]), i,j])/.{(Subscript[t, i|j])->0,(Subscript[T, i|j])->1}
(Subscript[tC, i])/.{(Subscript[t, i|j])->0,(Subscript[T, i|j])->1}

G0 = G/.ϵ->0
G1=G0;G1[[3]]=ϵ Coefficient[G[[3]],ϵ];G1

(Subscript[tBS, i,j->k])/.ϵ->0

(G0//(Subscript[tBS, i,j->k]))[[3]]
(G1//(Subscript[tBS, i,j->k]))[[3]]

(((Subscript[a, k]) (-2 (Subscript[T, k])+2 (Subscript[T, k]^3)))/(1-2 (Subscript[T, k])+3 (Subscript[T, k]^2)-2 (Subscript[T, k]^3)+(Subscript[T, k]^4)))+((-5 (Subscript[T, k])+28 (Subscript[T, k]^2)-37 (Subscript[T, k]^3)+12 (Subscript[T, k]^4)+2 (Subscript[T, k]^5))/(2-6 (Subscript[T, k])+12 (Subscript[T, k]^2)-14 (Subscript[T, k]^3)+12 (Subscript[T, k]^4)-6 (Subscript[T, k]^5)+2 (Subscript[T, k]^6)))/.(Subscript[a, k])->-1/2//Together

((G0/.{(Subscript[t, i|j])->0,(Subscript[T, i|j])->1})//((Subscript[tBS, i,j->k])/.(Subscript[𝒜, _])->1))[[3]]+
(G1//((Subscript[tBS, i,j->k])/.ϵ->0))[[3]]-(G//(Subscript[tBS, i,j->k]))[[3]]

(G0/.{(Subscript[t, i|j])->0,(Subscript[T, i|j])->1})
((Subscript[tBS, i,j->k])/.{(Subscript[𝒜, _])->1,(Subscript[x, _])->0,(Subscript[y, _])->0})

S1=𝔼[0,(Subscript[x, i]) (Subscript[y, i])-(Subscript[x, i]) (Subscript[y, j])+(Subscript[x, j]) (Subscript[y, j])+(-1+(Subscript[T, k])) (Subscript[η, j]) (Subscript[ξ, i])+(1-(Subscript[T, k])) (Subscript[η, i]) (Subscript[ξ, j]),(Subscript[T, k])+((-2 (Subscript[T, k])+2 (Subscript[T, k]^2)) (Subscript[η, i]) (Subscript[ξ, i])+(2 (Subscript[T, k])-2 (Subscript[T, k]^2)) (Subscript[η, j]) (Subscript[ξ, i])+(1/2) (-2 (Subscript[T, k])+2 (Subscript[T, k]^2)) (Subscript[η, i]) (Subscript[η, j]) (Subscript[ξ, i]^2)+(1/4) (3 (Subscript[T, k])-4 (Subscript[T, k]^2)+(Subscript[T, k]^3)) (Subscript[η, j]^2) (Subscript[ξ, i]^2)+(-2 (Subscript[T, k])+2 (Subscript[T, k]^2)) (Subscript[η, j]) (Subscript[ξ, j])+(3 (Subscript[T, k])-4 (Subscript[T, k]^2)+(Subscript[T, k]^3)) (Subscript[η, i]) (Subscript[η, j]) (Subscript[ξ, i]) (Subscript[ξ, j])+(1/2) (-2 (Subscript[T, k])+2 (Subscript[T, k]^2)) (Subscript[η, j]^2) (Subscript[ξ, i]) (Subscript[ξ, j])+(1/4) (-3 (Subscript[T, k])+4 (Subscript[T, k]^2)-(Subscript[T, k]^3)) (Subscript[η, i]^2) (Subscript[ξ, j]^2)) ϵ+((O[ϵ])^2)];

(Subscript[QZipM, {(Subscript[ξ, i]),(Subscript[ξ, j]),(Subscript[y, i]),(Subscript[y, j])}])[S1]

((G0/.{(Subscript[t, i|j])->0,(Subscript[T, i|j])->1})//((Subscript[tBS, i,j->k])/.(Subscript[𝒜, _])->1))[[3]]

((Subscript[tBS, i,j->k])/.ϵ->0)

G1//((Subscript[tBS, i,j->k])/.ϵ->0)

(Subscript[tC, 1])

(Subscript[tR, 1,2])

G//(Subscript[tBS, i,j->k])

Compare with trefoils:

(Subscript[tR, 5,1]) (Subscript[tR, 2,6]) (Subscript[tR, 7,3])(Subscript[tC, 4])(Subscript[(OverBar[tKink]), 8])(Subscript[(OverBar[tKink]), 9])(Subscript[(OverBar[tKink]), 10])//(Subscript[tm, 1,2->1])//(Subscript[tm, 1,3->1])//(Subscript[tm, 1,4->1])//(Subscript[tm, 1,5->1])//(Subscript[tm, 1,6->1])//(Subscript[tm, 1,7->1])//(Subscript[tm, 1,8->1])//(Subscript[tm, 1,9->1])//(Subscript[tm, 1,10->1])
(Subscript[(OverBar[tR]), 1,5]) (Subscript[(OverBar[tR]), 6,2]) (Subscript[(OverBar[tR]), 3,7])(Subscript[tC, 4])(Subscript[tKink, 8])(Subscript[tKink, 9])(Subscript[tKink, 10])//(Subscript[tm, 1,2->1])//(Subscript[tm, 1,3->1])//(Subscript[tm, 1,4->1])//(Subscript[tm, 1,5->1])//(Subscript[tm, 1,6->1])//(Subscript[tm, 1,7->1])//(Subscript[tm, 1,8->1])//(Subscript[tm, 1,9->1])//(Subscript[tm, 1,10->1])

(Subscript[tBS, i,j->k])/.{(Subscript[𝒜, i|j])->1}

Define[(Subscript[BB, i,j->k])=(Subscript[𝔼, {i,j}->{}])[0,(1-(Subscript[T, k]))((Subscript[η, i])(Subscript[ξ, j])-(Subscript[η, j])(Subscript[ξ, i])),(Subscript[T, k])]]

(Subscript[𝔼, {}->{i,j}])[0,(Subscript[y, i])(Subscript[x, i])-(Subscript[y, j])(Subscript[x, i])+(Subscript[y, j])(Subscript[x, j]),1]//(Subscript[BB, i,j->k])

(Subscript[𝔼, {}->{i,j}])[0,(Subscript[y, i])(Subscript[x, i])-(Subscript[y, j])(Subscript[x, i])+(Subscript[y, j])(Subscript[x, j]),1]//((Subscript[tBS, i,j->k])/.{(Subscript[𝒜, i|j])->1})

G

(Subscript[𝔼, {}->{i,j}])[(Subscript[a, i]) (Subscript[t, i])-(Subscript[a, i]) (Subscript[t, j])+(Subscript[a, j]) (Subscript[t, j]),(((Subscript[x, i]) (Subscript[y, i]))/(Subscript[T, j]))-(((Subscript[x, i]) (Subscript[y, j]))/(Subscript[T, j]))+(Subscript[x, j]) (Subscript[y, j]),(((Subscript[a, i])/((Sqrt[(Subscript[T, i])]) (Sqrt[(Subscript[T, j])])))+((Subscript[a, i]^2)/((Sqrt[(Subscript[T, i])]) (Sqrt[(Subscript[T, j])])))+((Subscript[a, j])/((Sqrt[(Subscript[T, i])]) (Sqrt[(Subscript[T, j])])))-(((Subscript[a, i]) (Subscript[a, j]))/((Sqrt[(Subscript[T, i])]) (Sqrt[(Subscript[T, j])])))+((Subscript[a, j]^2)/((Sqrt[(Subscript[T, i])]) (Sqrt[(Subscript[T, j])])))+(((Subscript[a, j]) (Subscript[x, i]) (Subscript[y, i]))/((Sqrt[(Subscript[T, i])]) (Subscript[T, j]^(3/2))))-(((Subscript[x, i]^2) (Subscript[y, i]^2))/(4 (Sqrt[(Subscript[T, i])]) (Subscript[T, j]^(5/2))))-(((Subscript[a, i]) (Subscript[x, i]) (Subscript[y, j]))/((Sqrt[(Subscript[T, i])]) (Subscript[T, j]^(3/2))))-(((Subscript[a, j]) (Subscript[x, i]) (Subscript[y, j]))/((Sqrt[(Subscript[T, i])]) (Subscript[T, j]^(3/2))))+(((Subscript[a, i]) (Subscript[x, j]) (Subscript[y, j]))/((Sqrt[(Subscript[T, i])]) (Sqrt[(Subscript[T, j])])))+(((Subscript[x, i]^2) (Subscript[y, i]) (Subscript[y, j]))/((Sqrt[(Subscript[T, i])]) (Subscript[T, j]^(5/2))))-(((Subscript[x, i]) (Subscript[x, j]) (Subscript[y, i]) (Subscript[y, j]))/((Sqrt[(Subscript[T, i])]) (Subscript[T, j]^(3/2))))-((3 (Subscript[x, i]^2) (Subscript[y, j]^2))/(4 (Sqrt[(Subscript[T, i])]) (Subscript[T, j]^(5/2))))+(((Subscript[x, i]) (Subscript[x, j]) (Subscript[y, j]^2))/((Sqrt[(Subscript[T, i])]) (Subscript[T, j]^(3/2))))-(((Subscript[x, j]^2) (Subscript[y, j]^2))/(4 (Sqrt[(Subscript[T, i])]) (Sqrt[(Subscript[T, j])])))) ϵ]//((Subscript[tBS, i,j->k])/.{(Subscript[𝒜, i|j])->1,ϵ->0})

((-5 (Subscript[T, k])+28 (Subscript[T, k]^2)-37 (Subscript[T, k]^3)+12 (Subscript[T, k]^4)+2 (Subscript[T, k]^5))/(2-6 (Subscript[T, k])+12 (Subscript[T, k]^2)-14 (Subscript[T, k]^3)+12 (Subscript[T, k]^4)-6 (Subscript[T, k]^5)+2 (Subscript[T, k]^6)))+(( (Subscript[T, k])-7  (Subscript[T, k]^3)+10  (Subscript[T, k]^4)-4  (Subscript[T, k]^5))/(2-6 (Subscript[T, k])+12 (Subscript[T, k]^2)-14 (Subscript[T, k]^3)+12 (Subscript[T, k]^4)-6 (Subscript[T, k]^5)+2 (Subscript[T, k]^6)))//Together

(Subscript[y, k]) (1-(Subscript[𝒜, j])) (Subscript[η, i])+(((Subscript[y, k]) (-(Subscript[𝒜, j])+(Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, j]))/(Subscript[𝒜, i]))+(((Subscript[x, k]) (-(Subscript[𝒜, i])+(Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[ξ, i]))/(Subscript[𝒜, j]))+(Subscript[x, k]) (1-(Subscript[𝒜, i])) (Subscript[ξ, j])+((Subscript[𝒜, i])-(Subscript[T, k]) (Subscript[𝒜, i])-(Subscript[𝒜, i]) (Subscript[𝒜, j])+(Subscript[T, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, i]) (Subscript[ξ, i])+(-(Subscript[𝒜, i])+(Subscript[T, k]) (Subscript[𝒜, i])-(Subscript[𝒜, j])+(Subscript[T, k]) (Subscript[𝒜, j])+(Subscript[𝒜, i]) (Subscript[𝒜, j])-(Subscript[T, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, j]) (Subscript[ξ, i])+((Subscript[𝒜, i]) (Subscript[𝒜, j])-(Subscript[T, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, i]) (Subscript[ξ, j])+((Subscript[𝒜, j])-(Subscript[T, k]) (Subscript[𝒜, j])-(Subscript[𝒜, i]) (Subscript[𝒜, j])+(Subscript[T, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, j]) (Subscript[ξ, j])

(Subscript[y, k]) (1-(Subscript[𝒜, j])) (Subscript[η, i])+(((Subscript[y, k]) (-(Subscript[𝒜, j])+(Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, j]))/(Subscript[𝒜, i]))+(((Subscript[x, k]) (-(Subscript[𝒜, i])+(Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[ξ, i]))/(Subscript[𝒜, j]))+(Subscript[x, k]) (1-(Subscript[𝒜, i])) (Subscript[ξ, j])+((Subscript[𝒜, i])-(Subscript[T, k]) (Subscript[𝒜, i])-(Subscript[𝒜, i]) (Subscript[𝒜, j])+(Subscript[T, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, i]) (Subscript[ξ, i])+(-(Subscript[𝒜, i])+(Subscript[T, k]) (Subscript[𝒜, i])-(Subscript[𝒜, j])+(Subscript[T, k]) (Subscript[𝒜, j])+(Subscript[𝒜, i]) (Subscript[𝒜, j])-(Subscript[T, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, j]) (Subscript[ξ, i])+((Subscript[𝒜, i]) (Subscript[𝒜, j])-(Subscript[T, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, i]) (Subscript[ξ, j])+((Subscript[𝒜, j])-(Subscript[T, k]) (Subscript[𝒜, j])-(Subscript[𝒜, i]) (Subscript[𝒜, j])+(Subscript[T, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, j]) (Subscript[ξ, j])//Simplify

(Subscript[y, k]) (1-(Subscript[𝒜, j])) (Subscript[η, i])+(((Subscript[y, k]) (-(Subscript[𝒜, j])+(Subscript[𝒜, i]) (Subscript[𝒜, j])) (Subscript[η, j]))/(Subscript[𝒜, i]))//Simplify

(Subscript[tBS, i,j->k])

D[(Subscript[tBS, i,j->k])[[3]],(Subscript[τ, j])]

(Subscript[tBS, i,j->k])/.{(Subscript[𝒜, i|j])->1,(Subscript[x, k])->0,(Subscript[y, k])->0,(Subscript[a, k])->0}

(Subscript[tBS, i,j->k])[[3]]/.{(Subscript[𝒜, i|j])->1,(Subscript[x, k])->0,(Subscript[y, k])->0,(Subscript[a, k])->0}

(Subscript[tm, i,j->k])

(Subscript[tm, i,j->k])/.{(Subscript[t, k])->0,(Subscript[T, k])->1}

((Subscript[tm, 1,2->k])//(Subscript[tm, k,3->k]))/.{(Subscript[t, k])->0,(Subscript[T, k])->1}

(Subscript[tS, k])

(((Subscript[tBS, i,j->k])//(Subscript[tS, k]))[[2]]-
((Subscript[tBS, i,j->k]))[[2]]//Together)/.{(Subscript[x, _])->0,(Subscript[y, _])->0}