Pensieve header: The full $sl_2$ invariant using the Drinfel’d double. Continues 2018-05/ybax.nb, Talks/StonyBrook-1805/ybax.nb, Projects/SL2Portfolio/Logoi.nb.

Profiling

Once[
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\SL2Invariant"];
<< KnotTheory`;
<<"../Profile/Profile.m";
];
BeginProfile[];
Once@PopupWindow[Button["Show Profile Monitor"],Dynamic[PrintProfile[], UpdateInterval->3, TrackedSymbols->{}]]

External Utilities

HL[ℰ_] := Style[ℰ, Background -> Yellow];

Program

Internal Utilities

Canonical Form:

CF[sd_SeriesData] := MapAt[CF,sd,3];
CF[ℰ_] := (Subscript[PP, CF])@ExpandDenominator@ExpandNumerator@(Subscript[PP, Together])@Together[(Subscript[PP, Exp])[
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, 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]);

Finite Zips:

collect[sd_SeriesData, ζ_] := MapAt[collect[#,ζ]&,sd,3];
collect[ℰ_,ζ_] := (Subscript[PP, Collect])@Collect[ℰ,ζ];
(Subscript[Zip, {}])[P_]:=P; (Subscript[Zip, {ζ_,ζs___}])[P_] := (Subscript[PP, Zip])[
(collect[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])@𝔼[L_,Q_,P_] := (Subscript[PP, QZip])@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;
CF /@ 𝔼[L,Q2,Det[qt](E^(-Q2))(Subscript[Zip, ζs])[(E^Q1)(P/.zrule)]] ];

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@ℰ))};

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,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;
CF /@ 𝔼[L2,Q2,Det[lt](E^(-L2-Q2))(Subscript[Zip, ζs])[(E^(L1+Q1))(P/.U2l/.zrule)]]//.l2U ];

(Subscript[Bind, {}])[L_,R_]:=L R;
(Subscript[Bind, {is__}])[L_𝔼,R_𝔼] := (Subscript[PP, Bind])@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, 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])[L_,R_]:=(Subscript[Bind, l])[L,R]; (Subscript[B, is___])[L_,R_]:=(Subscript[Bind, {is}])[L,R];

“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@$k])@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_}
}]  ]]

Booting Up

$k=2; ℏ=γ=1;

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

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

Define[(Subscript[aS, i])=(Subscript[𝔼[-(Subscript[α, i])(Subscript[a, j]),-(Subscript[ξ, i])(Subscript[x, i]),
Sum[Expand[(((E^((Subscript[ξ, i]) (Subscript[x, i])))(((-ℏ γ ϵ))^k))/((2^k)k!))Nest[Expand[(Subscript[x, i]^2)(∂_({(Subscript[x, i]),2}))#]&, (E^(-(Subscript[ξ, i]) (E^(ℏ ϵ (Subscript[a, i])))(Subscript[x, i]))),k]], {k,0,$k}]], $k])~(Subscript[B, i,j])~(Subscript[am, i,j->i]),
(Subscript[(OverBar[aS]), i])=𝔼[-(Subscript[a, i]) (Subscript[α, i]),-(Subscript[x, i]) (Subscript[𝒜, i]) (Subscript[ξ, i]),1+If[$k==0, 0,Normal@(Subscript[(OverBar[aS]), {i},$k-1])[[3]]-((Subscript[((Subscript[(OverBar[aS]), {i},0])), $k])~(Subscript[B, i])~(Subscript[aS, i])~(Subscript[B, i])~(Subscript[((Subscript[(OverBar[aS]), {i},$k-1])), $k]))[[3]]]]]

Define[(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]),
(Subscript[aΔ, i->j,k])=((Subscript[R, 1,j])(Subscript[R, 2,k]))~(Subscript[B, 1,2])~(Subscript[bm, 1,2->3])~(Subscript[B, 3])~(Subscript[P, 3,i]),
(Subscript[bΔ, i->j,k])=((Subscript[R, j,1])(Subscript[R, k,2]))~(Subscript[B, 1,2])~(Subscript[am, 1,2->3])~(Subscript[B, 3])~(Subscript[P, i,3])]

Define[(Subscript[dm, i,j->k])=(𝔼[(Subscript[β, i])(Subscript[b, i]) + (Subscript[α, j])(Subscript[a, j]),(Subscript[η, i])(Subscript[y, i])+(Subscript[ξ, j])(Subscript[x, j]),1]((Subscript[aΔ, i->1,2])~(Subscript[B, 2])~(Subscript[aΔ, 2->2,3])~(Subscript[B, 3])~(Subscript[(OverBar[aS]), 3]))((Subscript[bΔ, j->-1,-2])~(Subscript[B, -2])~(Subscript[bΔ, -2->-2,-3])))~(Subscript[B, -3,-2,-1,1,2,3,i,j])~((Subscript[P, -1,3])(Subscript[P, -3,1])(Subscript[am, 2,j->k])(Subscript[bm, i,-2->k])),
(Subscript[dS, i])=𝔼[(Subscript[β, i])(Subscript[b, 1])+(Subscript[α, i])(Subscript[a, 2]),(Subscript[η, i])(Subscript[y, 1])+(Subscript[ξ, i])(Subscript[x, 2]),1]~(Subscript[B, 1,2])~((Subscript[(OverBar[bS]), 1])(Subscript[aS, 2]))~(Subscript[B, 1,2])~(Subscript[dm, 2,1->i]),
(Subscript[dΔ, i->j,k])=((Subscript[bΔ, i->3,1])(Subscript[aΔ, i->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[dm, 3,4->k])(Subscript[dm, 1,2->j]))]

Define[ (Subscript[(OverBar[R]), i,j])=Expand/@(Subscript[R, i,j])~(Subscript[B, j])~(Subscript[dS, j]),
(Subscript[C, i])=(Subscript[𝔼[0,0,(Subscript[B, i]^(1/2))(E^(-ℏ ϵ (Subscript[a, i])/2))], $k]),
(Subscript[(OverBar[C]), i])=(Subscript[𝔼[0,0,(Subscript[B, i]^(-1/2))(E^(ℏ ϵ (Subscript[a, i])/2))], $k]),
(Subscript[Kink, i]) = ((Subscript[R, 1,3])(Subscript[(OverBar[C]), 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[dm, 1,3->i]),
(Subscript[(OverBar[Kink]), i]) = ((Subscript[(OverBar[R]), 1,3])(Subscript[C, 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[dm, 1,3->i])]

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

Define[(Subscript[b2t, i])=(Subscript[𝔼[(Subscript[α, i])(Subscript[a, i])-(Subscript[β, i])(Subscript[t, i])/γ,(Subscript[ξ, i])(Subscript[x, i])+(Subscript[η, i])(Subscript[y, i]),(E^(ϵ (Subscript[β, i])(Subscript[a, i])/γ))], $k]),
(Subscript[t2b, i])=(Subscript[𝔼[(Subscript[α, i])(Subscript[a, i])-(Subscript[τ, i])γ (Subscript[b, i]),(Subscript[ξ, i])(Subscript[x, i])+(Subscript[η, i])(Subscript[y, i]),(E^(ϵ (Subscript[τ, i])(Subscript[a, i])))], $k])]

Testing

Block[{$k=1}, {
am->(Subscript[am, i,j->k]),bm->(Subscript[bm, i,j->k]),dm->(Subscript[dm, i,j->k]),R->(Subscript[R, i,j]),(OverBar[R])->(Subscript[(OverBar[R]), i,j]),P->(Subscript[P, i,j]),aS->(Subscript[aS, i]),(OverBar[aS])->(Subscript[(OverBar[aS]), i]),bS->(Subscript[bS, i]),(OverBar[bS])->(Subscript[(OverBar[bS]), i]),dS->(Subscript[dS, i]),aΔ->(Subscript[aΔ, i->j,k]),bΔ->(Subscript[bΔ, i->j,k]),dΔ->(Subscript[dΔ, i->j,k]),C->(Subscript[C, i]),(OverBar[C])->(Subscript[(OverBar[C]), i]),Kink->(Subscript[Kink, i]),(OverBar[Kink])->(Subscript[(OverBar[Kink]), i]),b2t->(Subscript[b2t, i]),t2b->(Subscript[t2b, i])
}] // Column

Check that on the generators this agrees with our conventions in the handout:

Timing@{{"[a,x]"->((𝔼[0,0,(Subscript[a, 2])(Subscript[x, 1])]~(Subscript[B, 1,2])~(Subscript[am, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[a, 1])(Subscript[x, 2])]~(Subscript[B, 1,2])~(Subscript[am, 1,2->1]))[[3]]),
"[b,y]"->((𝔼[0,0,(Subscript[y, 2])(Subscript[b, 1])]~(Subscript[B, 1,2])~(Subscript[bm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[y, 1])(Subscript[b, 2])]~(Subscript[B, 1,2])~(Subscript[bm, 1,2->1]))[[3]])}/.(Subscript[z_, 1])->z,
{"Δ[y]"->Last[𝔼[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[bΔ, 1->1,2])],
"Δ[b]"->Last[𝔼[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[bΔ, 1->1,2])],
"Δ[a]"->Last[𝔼[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[aΔ, 1->1,2])],
"Δ[x]"->Last[𝔼[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[aΔ, 1->1,2])]},
{
"S(a)"->((𝔼[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[aS, 1]))[[3]]),
"S(x)"->((𝔼[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[aS, 1]))[[3]]),
"S(b)"->((𝔼[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[bS, 1]))[[3]]),
"S(y)"->((𝔼[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[bS, 1]))[[3]])
}/.(Subscript[z_, 1])->z}

Hopf algebra axioms on both sides separately.

Associativity of am and bm:

Timing@Block[{$k=3},
HL/@{((Subscript[am, 1,2->1])~(Subscript[B, 1])~(Subscript[am, 1,3->1]))≡((Subscript[am, 2,3->2])~(Subscript[B, 2])~(Subscript[am, 1,2->1])),((Subscript[bm, 1,2->1])~(Subscript[B, 1])~(Subscript[bm, 1,3->1]))≡((Subscript[bm, 2,3->2])~(Subscript[B, 2])~(Subscript[bm, 1,2->1]))}
]

R and P are inverses:

Timing@Block[{$k=3},{(Subscript[R, i,j]),(Subscript[P, i,k]),HL[(Subscript[R, i,j])~(Subscript[B, i])~(Subscript[P, i,k])≡𝔼[(Subscript[a, j]) (Subscript[α, k]),(Subscript[x, j]) (Subscript[ξ, k]),1]]}]

as and (OverBar[aS]) are inverses, bs and (OverBar[bS]) are inverses:

Timing[HL/@{(Subscript[(OverBar[aS]), 1])~(Subscript[B, 1])~(Subscript[aS, 1])≡𝔼[(Subscript[a, 1]) (Subscript[α, 1]),(Subscript[x, 1]) (Subscript[ξ, 1]),1], (Subscript[(OverBar[bS]), 1])~(Subscript[B, 1])~(Subscript[bS, 1])≡𝔼[(Subscript[b, 1]) (Subscript[β, 1]),(Subscript[y, 1]) (Subscript[η, 1]),1]}]

(co)-associativity on both sides

Timing[HL /@ {((Subscript[aΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[aΔ, 2->2,3]))≡((Subscript[aΔ, 1->1,3])~(Subscript[B, 1])~(Subscript[aΔ, 1->1,2])),((Subscript[bΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[bΔ, 2->2,3]))≡((Subscript[bΔ, 1->1,3])~(Subscript[B, 1])~(Subscript[bΔ, 1->1,2])),((Subscript[am, 1,2->1])~(Subscript[B, 1])~(Subscript[am, 1,3->1]))≡((Subscript[am, 2,3->2])~(Subscript[B, 2])~(Subscript[am, 1,2->1])),((Subscript[bm, 1,2->1])~(Subscript[B, 1])~(Subscript[bm, 1,3->1]))≡((Subscript[bm, 2,3->2])~(Subscript[B, 2])~(Subscript[bm, 1,2->1]))}]

Δ is an algebra morphism

Timing[HL /@ {(Subscript[am, 1,2->1])~(Subscript[B, 1])~(Subscript[aΔ, 1->1,2])≡((Subscript[aΔ, 1->1,3])(Subscript[aΔ, 2->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[am, 3,4->2])(Subscript[am, 1,2->1])),
(Subscript[bm, 1,2->1])~(Subscript[B, 1])~(Subscript[bΔ, 1->1,2])≡((Subscript[bΔ, 1->1,3])(Subscript[bΔ, 2->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[bm, 3,4->2])(Subscript[bm, 1,2->1]))}]

S is convolution inverse of id

Timing[HL[#≡𝔼[0,0,1]]& /@ {
((Subscript[aΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[aS, 1]))~(Subscript[B, 1,2])~(Subscript[am, 1,2->1]),((Subscript[aΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[aS, 2]))~(Subscript[B, 1,2])~(Subscript[am, 1,2->1]), ((Subscript[bΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[bS, 1]))~(Subscript[B, 1,2])~(Subscript[bm, 1,2->1]),((Subscript[bΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[bS, 2]))~(Subscript[B, 1,2])~(Subscript[bm, 1,2->1])}]

But not with the opposite product:

Timing[Short[#≡𝔼[0,0,1]]& /@ {
((Subscript[aΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[aS, 1]))~(Subscript[B, 1,2])~(Subscript[am, 2,1->1]),((Subscript[aΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[aS, 2]))~(Subscript[B, 1,2])~(Subscript[am, 2,1->1]), ((Subscript[bΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[bS, 1]))~(Subscript[B, 1,2])~(Subscript[bm, 2,1->1]),((Subscript[bΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[bS, 2]))~(Subscript[B, 1,2])~(Subscript[bm, 2,1->1])}]

S is an algebra anti-(co)morphism

Timing[HL/@{(Subscript[am, 1,2->1])~(Subscript[B, 1])~(Subscript[aS, 1])≡((Subscript[aS, 1])(Subscript[aS, 2]))~(Subscript[B, 1,2])~(Subscript[am, 2,1->1]),(Subscript[bm, 1,2->1])~(Subscript[B, 1])~(Subscript[bS, 1])≡((Subscript[bS, 1])(Subscript[bS, 2]))~(Subscript[B, 1,2])~(Subscript[bm, 2,1->1]), (Subscript[aS, 1])~(Subscript[B, 1])~(Subscript[aΔ, 1->1,2])≡(Subscript[aΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[aS, 1])(Subscript[aS, 2])),(Subscript[bS, 1])~(Subscript[B, 1])~(Subscript[bΔ, 1->1,2])≡(Subscript[bΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[bS, 1])(Subscript[bS, 2]))}]

Pairing axioms

Timing[HL/@{((Subscript[bm, 1,2->1]) 𝔼[(Subscript[α, 3])(Subscript[a, 3]),(Subscript[ξ, 3])(Subscript[x, 3]),1])~(Subscript[B, 1,3])~(Subscript[P, 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[aΔ, 3->4,5]))~(Subscript[B, 1,4])~(Subscript[P, 1,4])~(Subscript[B, 2,5])~(Subscript[P, 2,5]),((Subscript[bΔ, 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[P, 1,3])~(Subscript[B, 2,4])~(Subscript[P, 2,4])≡( 𝔼[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1](Subscript[am, 3,4->3]))~(Subscript[B, 1,3])~(Subscript[P, 1,3]) }]

Timing[HL/@{((Subscript[bS, 1])𝔼[(Subscript[α, 2])(Subscript[a, 2]),(Subscript[ξ, 2])(Subscript[x, 2]),1])~(Subscript[B, 1,2])~(Subscript[P, 1,2])≡(𝔼[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1](Subscript[aS, 2]))~(Subscript[B, 1,2])~(Subscript[P, 1,2]),
((Subscript[(OverBar[bS]), 1])𝔼[(Subscript[α, 2])(Subscript[a, 2]),(Subscript[ξ, 2])(Subscript[x, 2]),1])~(Subscript[B, 1,2])~(Subscript[P, 1,2])≡(𝔼[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1](Subscript[(OverBar[aS]), 2]))~(Subscript[B, 1,2])~(Subscript[P, 1,2])}]

Tests for the double.

Check the double formulas on the generators agree with SL2Portfolio.pdf:

Timing@{{
"[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]]),
"[b,x]"   ->((𝔼[0,0,(Subscript[x, 2])(Subscript[b, 1])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[[3]]-(𝔼[0,0,(Subscript[x, 1])(Subscript[b, 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}//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]]),
"Δ(b)"->((𝔼[0,0,(Subscript[b, 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]])
}//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(b)"->((𝔼[0,0,(Subscript[b, 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}//Simplify
}

(co)-associativity

Timing[HL/@{((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

Timing@HL[(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]))]

S is convolution inverse of id

Timing[HL[#≡𝔼[0,0,1]]& /@ {((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])}]

S is a (co)-algebra anti-morphism

Timing[HL/@Expand/@{(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]))}]

Quasi-triangular axiom 1:

Timing@HL[(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:

Timing@HL[(((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])))]

The Drinfel’d element inverse property, ((Subscript[u, 1])(Subscript[(OverBar[u]), 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])≡𝔼[0,0,1]:

Timing@HL[(((Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[dS, 1])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->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->j])))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])≡𝔼[0,0,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.

Timing@Block[{$k=3},((((Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[dS, 1])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->i]))~(Subscript[B, i])~(Subscript[dS, 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->j])))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])]

Timing@Block[{$k=2},HL/@{((Subscript[C, i])(Subscript[(OverBar[C]), j]))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])≡𝔼[0,0,1],((Subscript[(OverBar[C]), i])(Subscript[(OverBar[C]), j]))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])≡((((Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[dS, 1])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->i]))~(Subscript[B, i])~(Subscript[dS, 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->j])))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])}]

Reidemeister 2:

Timing[HL[#≡𝔼[0,0,1]]&/@{((Subscript[(OverBar[R]), 1,2])(Subscript[R, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[dm, 1,3->1])(Subscript[dm, 2,4->2])),((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[dm, 1,3->1])(Subscript[dm, 2,4->2]))}]

Cyclic Reidemeister 2:

Timing@HL[((Subscript[R, 1,4])(Subscript[(OverBar[R]), 5,2])(Subscript[(OverBar[C]), 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[C]), 1])]

Reidemeister 3:

Timing@HL[(((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]))]

Relations between the four kinks:

Timing[HL/@{(Subscript[Kink, i])≡((Subscript[R, 3,1])(Subscript[C, 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]), 3,1])(Subscript[(OverBar[C]), 2]))~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[dm, 1,3->j]),((Subscript[Kink, i]) (Subscript[(OverBar[Kink]), j]))~(Subscript[B, i,j])~(Subscript[dm, i,j->1])≡𝔼[0,0,1]}]

The Trefoil

Timing@Block[{$k=1},
Z=(Subscript[R, 1,5])(Subscript[R, 6,2])(Subscript[R, 3,7])(Subscript[(OverBar[C]), 4])(Subscript[(OverBar[Kink]), 8])(Subscript[(OverBar[Kink]), 9])(Subscript[(OverBar[Kink]), 10]);
Do[Z=Z~(Subscript[B, 1,r])~(Subscript[dm, 1,r->1]),{r,2,10}];
{Simplify/@Z, Simplify/@(Z~(Subscript[B, 1])~(Subscript[b2t, 1]) /. (Subscript[T, 1])->T)}]

Define[(Subscript[kR, i,j])=(Subscript[R, i,j])~(Subscript[B, i,j])~((Subscript[b2t, i])(Subscript[b2t, j])) /. (Subscript[t, i|j])->t,
(Subscript[(OverBar[kR]), i,j])=(Subscript[(OverBar[R]), i,j])~(Subscript[B, 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[B, i,j])~(Subscript[dm, i,j->k])~(Subscript[B, k])~(Subscript[b2t, k]) /. {(Subscript[t, k])->t, (Subscript[T, k])->T,(Subscript[τ, i|j])->0},
(Subscript[kC, i])=(Subscript[C, i])~(Subscript[B, i])~(Subscript[b2t, i]) /. (Subscript[T, i])->T,
(Subscript[(OverBar[kC]), i])=(Subscript[(OverBar[C]), i])~(Subscript[B, i])~(Subscript[b2t, i]) /. (Subscript[T, i])->T,
(Subscript[kKink, i])=(Subscript[Kink, i])~(Subscript[B, i])~(Subscript[b2t, i]) /. {(Subscript[t, i])->t, (Subscript[T, i])->T},
(Subscript[(OverBar[kKink]), i])=(Subscript[(OverBar[Kink]), i])~(Subscript[B, i])~(Subscript[b2t, i]) /. {(Subscript[t, i])->t, (Subscript[T, i])->T}]

Timing@Block[{$k=1},
Z=(Subscript[kR, 1,5])(Subscript[kR, 6,2])(Subscript[kR, 3,7])(Subscript[(OverBar[kC]), 4])(Subscript[(OverBar[kKink]), 8])(Subscript[(OverBar[kKink]), 9])(Subscript[(OverBar[kKink]), 10]);
Do[Z=Z~(Subscript[B, 1,r])~(Subscript[km, 1,r->1]),{r,2,10}];
Simplify/@Z]

RVK, rot, Z from 2016-09/OneSmidgen.nb. See also local version in this folder.

RVK::usage="RVK[xs, rots] represents a Rotational Virtual Knot with a list of n Xp/Xm crossings xs and a length 2n list of rotation numbers rots. Crossing sites are indexed 1 through 2n, and rots[[k]] is the rotation between site k-1 and site k. RVK is also a casting operator converting to the RVK presentation from other knot presentations.";

RVK[pd_PD] := (Subscript[PP, RVK])@Module[{n,xs,x,rots,front,k},
n=Length[pd];
xs=List@@pd /. x_X :> If[PositiveQ[x], Xp[x[[4]],x[[1]]], Xm[x[[2]],x[[1]]]];
rots=Table[0, {2n}];
front={0};
For[k=0, k<2n, ++k,
If[k==0∨FreeQ[front, -k],
front = Flatten[front /. k->Catch[xs /. {
Xp[k+1,l_]|Xm[l_,k+1] :> Throw[{l,k+1,1-l}],
Xp[l_,k+1]|Xm[k+1,l_] :> (++rots[[l]]; Throw[{1-l,k+1,l}])
}]],
If[MatchQ[front,{___,k,___,-k,___}], --rots[[k+1]]]
]
];
RVK[xs,rots]
];
RVK[K_] := RVK[PD[K]];

RVK[Knot[3,1]]

rot[_,0] = 𝔼[0,0,1];
rot[i_,n_Integer] /; n>0 := rot[i,n]=Module[{j}, (rot[i,n-1](Subscript[kC, j]))~(Subscript[B, i,j])~(Subscript[km, i,j->i])];
rot[i_,n_Integer] /; n<0 := rot[i,n]=Module[{j}, (rot[i,n+1](Subscript[(OverBar[kC]), j]))~(Subscript[B, i,j])~(Subscript[km, i,j->i])];

rot[i,-3]

Z[K_] := Z[RVK@K];
Z[rvk_RVK] := (*Z[rvk] =*) (Subscript[PP, "Z"])@Module[{todo,n,rots,ζ,done,st,cx, ζ1, i,j,k,k1,k2,k3},
{todo,rots}=List@@rvk;
AppendTo[rots,0];
n=Length[todo];
ζ=𝔼[0,0,1];
done={0};
st=Range[0,2n+1];
While[todo=!={},
{cx}=MaximalBy[todo, Length[done⋂{#[[1]], #[[2]], #[[1]]-1,#[[2]]-1}]&,1];
{i,j}=List@@cx;
ζ1=Switch[Head[cx],
 Xp, ((Subscript[kR, i,j])(Subscript[(OverBar[kKink]), k]))~(Subscript[B, j,k])~(Subscript[km, j,k->j]),
 Xm, ((Subscript[(OverBar[kR]), i,j])(Subscript[kKink, k]))~(Subscript[B, j,k])~(Subscript[km, j,k->j])
];
ζ1=(rot[k,rots[[i]]]ζ1)~(Subscript[B, k,i])~(Subscript[km, k,i->i]); rots[[i]]=0;
ζ1=(ζ1 rot[k, rots[[i+1]]])~(Subscript[B, i,k])~(Subscript[km, i,k->i]); rots[[i+1]]=0;
ζ1=(rot[k,rots[[j]]]ζ1)~(Subscript[B, k,j])~(Subscript[km, k,j->j]); rots[[j]]=0;
ζ1=(ζ1 rot[k, rots[[j+1]]])~(Subscript[B, j,k])~(Subscript[km, j,k->j]); rots[[j+1]]=0;
ζ*=ζ1;
If[MemberQ[done, i], ζ=ζ~(Subscript[B, i,i+1])~(Subscript[km, i,i+1->i]); st=st/.st[[i+2]]->st[[i+1]]];
If[MemberQ[done, i-1],  ζ=ζ~(Subscript[B, st[[i]],i])~(Subscript[km, st[[i]],i->st[[i]]]); st=st/.st[[i+1]]->st[[i]]]; 
If[MemberQ[done, j],  ζ=ζ~(Subscript[B, j,j+1])~(Subscript[km, j,j+1->j]); st=st/.st[[j+2]]->st[[j+1]]]; 
If[MemberQ[done, j-1],  ζ=ζ~(Subscript[B, st[[j]],j])~(Subscript[km, st[[j]],j->st[[j]]]); st=st/.st[[j+1]]->st[[j]]];
done=done⋃{i-1,i,j-1,j};
todo=DeleteCases[todo, cx]
];
Simplify/@ (ζ /. {(Subscript[x, 0])->x,(Subscript[y, 0])->y,(Subscript[a, 0])->a})
]

$k=1; Timing@Z@Knot[10,100]

EndProfile[];

PrintProfile[]