A twisted Yetter-Drinfeld version of (Subscript[ρ, 1])

Mixing Garoufalidis-Kashaev section 6 with Gaussians and q = 1+h. Scroll to the very end of this file to see the knot invariants. They (experimentally) match exactly the 2-loop polynomials previously computed by other means by Ohtsuki, Rozansky and many others.

Internal Utilities and familiar things from our Gaussian calculus

Quiet@Once[<<KnotTheory`];

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

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

𝔼/:𝔼[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[x])=ξ;(SuperStar[ξ])=x; (SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]);

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

collect[sd_SeriesData, ζ_] := MapAt[collect[#,ζ]&,sd,3];
collect[ℰ_,ζ_] := Collect[ℰ,ζ];
(Subscript[Zip, {}])[P_]:=P;
(Subscript[Zip, ζs_])[Ps_List]:=(Subscript[Zip, ζs])/@Ps;
(Subscript[Zip, {ζ_,ζs___}])[P_] := 
(collect[P//(Subscript[Zip, {ζs}]),ζ] /. f_.(ζ^(d_.)):>((Subscript[D, {(SuperStar[ζ]),d}])[f]))/.(SuperStar[ζ])->0/.((SuperStar[ζ])->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_] := 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}];
(*Echo@MatrixForm@Table[(∂_(z,ζ))Q,{ζ,ζs},{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[B, {}])[L_,R_]:=L R;
(Subscript[B, {is__}])[L_𝔼,R_𝔼] := Module[{n},
Times[
L/.Table[(Subscript[x, i])->(Subscript[x, n@i]),{i,{is}}],
R/.Table[(Subscript[ξ, i])->(Subscript[ξ, n@i]),{i,{is}}]
]  // (Subscript[QZip, Join@@Table[{(Subscript[ξ, n@i])},{i,{is}}]]) ];
(Subscript[B, is___])[L_,R_]:=(Subscript[B, {is}])[L,R];

(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[𝔼, _])[ℰ___][i_]:={ℰ}[[i]];

$k=0;
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]),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 new objects:

$n=1; Define[
(Subscript[nI, i])=(Subscript[𝔼, {i}->{i}])[0,(Subscript[ξ, i])(Subscript[x, i]),1],
(Subscript[nm, i,j->k])=(Subscript[𝔼, {i,j}->{k}])[0,((Subscript[ξ, i])+(Subscript[ξ, j]))(Subscript[x, k]),1],
(Subscript[nτ, i,j])=(Subscript[𝔼, {i,j}->{i,j}])[0,(Subscript[ξ, i])(Subscript[x, i])+(Subscript[ξ, j])(Subscript[x, j]),1+ℏ (Subscript[ξ, i])(Subscript[x, i])(Subscript[ξ, j])(Subscript[x, j])+((O[ℏ])^2)],
(Subscript[(OverBar[nτ]), i,j])=(Subscript[𝔼, {i,j}->{i,j}])[0,(Subscript[ξ, i])(Subscript[x, i])+(Subscript[ξ, j])(Subscript[x, j]),1-ℏ (Subscript[ξ, i])(Subscript[x, i])(Subscript[ξ, j])(Subscript[x, j])+((O[ℏ])^2)](**),
(Subscript[nS, i])=(Subscript[𝔼, {i}->{i}])[0,-(Subscript[ξ, i])(Subscript[x, i]),1+ℏ((((Subscript[ξ, i])^2)((Subscript[x, i])^2))/2)+((O[ℏ])^2)],
(Subscript[(OverBar[nS]), i])=(Subscript[𝔼, {i}->{i}])[0,-(Subscript[ξ, i])(Subscript[x, i]),1-ℏ((((Subscript[ξ, i])^2)((Subscript[x, i])^2))/2)+((O[ℏ])^2)],
(Subscript[nΔ, i->j,k])=(Subscript[𝔼, {i}->{j,k}])[0,((Subscript[x, j])+(Subscript[x, k]))(Subscript[ξ, i]),1+ℏ((((Subscript[ξ, i])^2)(Subscript[x, j])(Subscript[x, k]))/2)+((O[ℏ])^2)],
(Subscript[nϕ, i])=(Subscript[𝔼, {i}->{i}])[0,T (Subscript[ξ, i])(Subscript[x, i]),1],
(Subscript[(OverBar[nϕ]), i])=(Subscript[𝔼, {i}->{i}])[0,(T^(-1)) (Subscript[ξ, i])(Subscript[x, i]),1],
(Subscript[nδ, i->j,k])=(Subscript[nΔ, i->1,2])//(Subscript[nΔ, 2->k,3])//(Subscript[nS, 3])//(Subscript[nϕ, 3])//(Subscript[nτ, k,3])//(Subscript[nm, 1,3->j]),
(Subscript[nR, i,j])=(Subscript[nϕ, j])//(Subscript[nδ, i->1,i])//(Subscript[nτ, i,j])//(Subscript[nm, 1,j->j]),
(Subscript[(OverBar[nR]), i,j])=(Subscript[nδ, i->z1,i])//(Subscript[(OverBar[nτ]), z1,j])//(Subscript[(OverBar[nS]), z1])//(Subscript[(OverBar[nτ]), i,j])//(Subscript[(OverBar[nτ]), i,z1])//(Subscript[nm, z1,j->j])//(Subscript[(OverBar[nϕ]), j]),
(Subscript[nC, i])=(Subscript[𝔼, {i}->{i}])[0,(Subscript[ξ, i])(Subscript[x, i]),1+ (Subscript[ξ, i])(Subscript[x, i]) ℏ+((O[ℏ])^2)],(Subscript[(OverBar[nC]), i])=(Subscript[𝔼, {i}->{i}])[0,(Subscript[ξ, i])(Subscript[x, i]),1-(Subscript[ξ, i])(Subscript[x, i]) ℏ+((O[ℏ])^2)],
(Subscript[nKinkr, i])=((Subscript[nR, 1,3])(Subscript[(OverBar[nC]), 2])//(Subscript[nμ, 1,2->1])//(Subscript[nμ, 1,3->i])),
(Subscript[nKinkl, i])=((Subscript[nR, 3,1])(Subscript[nC, 2])//(Subscript[nμ, 1,2->1])//(Subscript[nμ, 1,3->i])),
(Subscript[(OverBar[nKinkr]), i])=((Subscript[(OverBar[nR]), 3,1])(Subscript[(OverBar[nC]), 2])//(Subscript[nμ, 1,2->1])//(Subscript[nμ, 1,3->i])),
(Subscript[(OverBar[nKinkl]), i])=((Subscript[(OverBar[nR]), 1,3])(Subscript[nC, 2])//(Subscript[nμ, 1,2->1])//(Subscript[nμ, 1,3->i])) ]

(*For composing tensors, leg by leg*)
(Subscript[nμ, i_,j_->k_])[(Subscript[𝔼, d_->r_])[0,Q_,P_]]:=Module[{v},
(Subscript[QZip, {(Subscript[ξ, v])}])[𝔼[0,Q/.{(Subscript[ξ, j])->(Subscript[ξ, v]),(Subscript[x, i])->(Subscript[x, v]),(Subscript[ξ, i])->(Subscript[ξ, k]),(Subscript[x, j])->(Subscript[x, k])},P/.{(Subscript[ξ, j])->(Subscript[ξ, v]),(Subscript[x, i])->(Subscript[x, v]),(Subscript[ξ, i])->(Subscript[ξ, k]),(Subscript[x, j])->(Subscript[x, k])}]]
]/.𝔼->(Subscript[𝔼, (d/.{i->Nothing,j->k})->(r/.{i->Nothing,j->k})])

(Subscript[nδ, i->j,k])

(Subscript[nR, i,j])

(Subscript[nϕ, j])//(Subscript[nδ, i->1,i])//(Subscript[nτ, i,j])//(Subscript[nm, 1,j->j])

(Subscript[nC, 1])//(Subscript[(OverBar[nC]), 1])

Table[(∂_(Subscript[ξ, v]))(∂_(Subscript[x, u]))((Subscript[x, il]) (Subscript[ξ, il])+(1-T) (Subscript[x, jl]) (Subscript[ξ, il])+(-1+T) (Subscript[x, jr]) (Subscript[ξ, il])+(((Subscript[x, ir]) (Subscript[ξ, ir]))/T)+(1-T) (Subscript[x, jr]) (Subscript[ξ, ir])+(((-1+T) (Subscript[x, ir]) (Subscript[ξ, jl]))/T)+T (Subscript[x, jl]) (Subscript[ξ, jl])+(Subscript[x, jr]) (Subscript[ξ, jr])),{u,{il,ir,jl,jr}},{v,{il,ir,jl,jr}}]//Expand//MatrixForm

Det[IdentityMatrix[6]-(({{0, T, 0, 0, 0, 0}, {0, 0, 1, 0, 0, 0}, {0, 0, 0, 1, 0, 0}, {0, 0, 0, 0, T, 0}, {0, 1-T, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0}}))]

(Subscript[QZip, Table[(Subscript[ξ, v]),{v,1,6}]])[𝔼@@(((Subscript[nR, 1,5])(Subscript[nR, 6,2])(Subscript[nR, 3,7])(Subscript[(OverBar[nC]), 4]))/.{(Subscript[ξ, u_]):>(Subscript[ξ, u-1])})]

(Subscript[nR, 1,5])(Subscript[nR, 6,2])(Subscript[nR, 3,7])(Subscript[(OverBar[nC]), 4])//(Subscript[nμ, 1,2->1])//(Subscript[nμ, 1,3->1])//(Subscript[nμ, 1,4->1])//(Subscript[nμ, 1,5->1])//(Subscript[nμ, 1,6->1])//(Subscript[nμ, 1,7->1])

(Subscript[Mx, i_,j_]):=(Subscript[x, i]) (Subscript[ξ, i])+(1-T) (Subscript[x, j]) (Subscript[ξ, i])+T (Subscript[x, j]) (Subscript[ξ, j])
(Subscript[(OverBar[Mx]), i_,j_]):=(Subscript[x, i]) (Subscript[ξ, i])+(1-T) (Subscript[x, j]) (Subscript[ξ, i])+T (Subscript[x, j]) (Subscript[ξ, j])

Mat=Table[(∂_(Subscript[ξ, j]))(∂_(Subscript[x, i]))((Subscript[Mx, 1,4])+(Subscript[Mx, 5,2])+(Subscript[Mx, 3,6])),{i,1,6},{j,1,6}];
%//MatrixForm
Mat=Table[(∂_(Subscript[ξ, j]))(∂_(Subscript[x, i-1]))((Subscript[Mx, 1,4])+(Subscript[Mx, 5,2])+(Subscript[Mx, 3,6])),{i,2,7},{j,2,7}];
%//MatrixForm
Det[IdentityMatrix[6]-Mat]

(Subscript[nR, a,3])(Subscript[nΔ, b->1,2])//(Subscript[nμ, a,b->c])

(Subscript[𝔼, {3,c}->{1,2,3}])[0,T (Subscript[x, 3]) (Subscript[ξ, 3])+(1-T) (Subscript[ξ, c])+(Subscript[x, 1]) (Subscript[ξ, c])+(Subscript[x, 2]) (Subscript[ξ, c]),1+(t (Subscript[x, 1]) (Subscript[x, 3]) (Subscript[ξ, 3]) (Subscript[ξ, c])+t (Subscript[x, 2]) (Subscript[x, 3]) (Subscript[ξ, 3]) (Subscript[ξ, c])+(1/2) (-t+(t^2)) (Subscript[ξ, c]^2)+(1/2) (1-3 t) (Subscript[x, 1]) (Subscript[ξ, c]^2)+(1/2) (1-3 t) (Subscript[x, 2]) (Subscript[ξ, c]^2)+(1/2) (Subscript[x, 1]) (Subscript[x, 2]) (Subscript[ξ, c]^2)) ℏ+((O[ℏ])^2)/.t->T]

(Subscript[nR, a,3])//(Subscript[nΔ, a->1,2])

(Subscript[nR, 1,3])(Subscript[nR, 2,4])//(Subscript[nμ, 4,3->3])
(Subscript[nR, 2,3])//(Subscript[nR, 1,3])

Testing:

(Subscript[nR, 1,2])
(Subscript[(OverBar[nR]), 1,2])

(*Reidemeister 3 in two ways*)
((Subscript[nR, 1,2])//(Subscript[nR, 1,3])//(Subscript[nR, 2,3]))≡
((Subscript[nR, 2,3])//(Subscript[nR, 1,3])//(Subscript[nR, 1,2]))

((Subscript[nR, 1,2])(Subscript[nR, 4,3])(Subscript[nR, 5,6])//(Subscript[nμ, 1,4->1])//(Subscript[nμ, 2,5->2])//(Subscript[nμ, 3,6->3]))≡
((Subscript[nR, 1,6])(Subscript[nR, 2,3])(Subscript[nR, 4,5])//(Subscript[nμ, 1,4->1])//(Subscript[nμ, 2,5->2])//(Subscript[nμ, 3,6->3]))

(*Reidemeister 2b in two ways*)
((Subscript[nR, 1,2])(Subscript[(OverBar[nR]), 3,4])//(Subscript[nμ, 1,3->1])//(Subscript[nμ, 2,4->2]))≡(Subscript[nI, 1])(Subscript[nI, 2])
((Subscript[nR, 1,2])//(Subscript[(OverBar[nR]), 1,2]))≡(Subscript[nI, 1])(Subscript[nI, 2])

(*Reidemeister 2c works with an almost trivial C...*)

((Subscript[(OverBar[nR]), 1,4])(Subscript[nR, 3,2])(Subscript[nC, 6])//(Subscript[nμ, 1,3->1])//(Subscript[nμ, 2,6->2])//(Subscript[nμ, 2,4->2]))≡
(Subscript[nI, 1])(Subscript[nC, 2])

(*Explicit Figure eight knot*)
Z41=(Subscript[(OverBar[nR]), 8,1])(Subscript[nR, 10,3])(Subscript[nR, 5,9])(Subscript[(OverBar[nR]), 2,6])(Subscript[nC, 4])(Subscript[(OverBar[nC]), 7]);
Do[Z41=Z41//(Subscript[nμ, 1,j->1]),{j,2,10}];
Z41//Factor

(*Kinks don't match well, so all four need to be considered*)
{(Subscript[nKinkl, 1]),(Subscript[nKinkr, 1]),(Subscript[(OverBar[nKinkl]), 1]),(Subscript[(OverBar[nKinkr]), 1])}

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]:=Module[{n,xs,x,rots,front={0},k},
n=Length@pd;rots=Table[0,{2n}];
xs=Cases[pd,x_X:>(Piecewise[{{Xp[x[[4]],x[[1]]], PositiveQ@x}, {Xm[x[[2]],x[[1]]], True}}])];
For[k=0,k<2n,++k,If[k==0∨FreeQ[front,-k],
front=Flatten@Replace[front,k->(xs/.{
Xp[k+1,l_]|Xm[l_,k+1]:>{l,k+1,1-l},
Xp[l_,k+1]|Xm[k+1,l_]:>(++rots[[l]];{1-l,k+1,l}),
_Xp|_Xm:>{}
}), {1}],
Cases[front,k|-k]/.{k,-k}:>--rots[[k+1]];
]];
RVK[xs,rots] ];
RVK[K_]:=RVK[PD[K]];

rot[i_,0]:=(Subscript[nI, i]);
rot[i_,n_]:=rot[i,n,$k];
rot[i_,n_,k_]:=Module[{j},
rot[i,n,k]=If[n>0,rot[i,n-1](Subscript[nC, j]),rot[i,n+1](Subscript[(OverBar[nC]), j])]//(Subscript[nμ, i,j->i])];

Width[pd_PD]:=Max[Length/@FoldList[Complement[#1⋃#2,#1⋂#2]&, {}, List@@List@@@pd]]

ThinPosition[K_]:=Module[{todo,done,pd,c},
todo=List@@PD@K; done={}; pd=PD[];
While[todo=!={},
AppendTo[pd,c=RandomChoice@MaximalBy[todo, Length[done⋂List@@#]&]];
todo=DeleteCases[todo, c];
done=done⋃List@@c];
pd ];
ThinPosition[K_,n_] := First@MinimalBy[Table[ThinPosition[K], n], Width];

Z[K_] := Z[RVK@ThinPosition[K,100]];
Z[rvk_RVK] := Monitor[ Module[{ζ,done,st,c, χ,i,j,k,totrot=Total[rvk[[2]]]},
ζ=1; done={}; st=Range[2Length[rvk[[1]]]]; $M={};
Do[AppendTo[$M,c];
{i,j}=List@@c;
If[Head[c]===Xp,If[totrot<=0,totrot++;χ=(Subscript[(OverBar[nKinkl]), 0])(Subscript[nR, i,j])//(Subscript[nμ, j,0->j]),totrot--;χ=(Subscript[(OverBar[nKinkr]), 0])(Subscript[nR, i,j])//(Subscript[nμ, j,0->j])] ,
If[totrot<=0,totrot++;χ=(Subscript[nKinkl, 0])(Subscript[(OverBar[nR]), i,j])//(Subscript[nμ, j,0->j]),totrot--;χ=(Subscript[nKinkr, 0])(Subscript[(OverBar[nR]), i,j])//(Subscript[nμ, j,0->j])] 
 ];
Do[χ=(rot[0,rvk[[2,k]]]χ)//(Subscript[nμ, 0,k->k]), {k,{i,j}}];
ζ*=χ;
Do[
If[MemberQ[done, k+1],ζ=ζ//(Subscript[nμ, k,k+1->k]); st=st/.k+1->k];
If[MemberQ[done, k-1],ζ=ζ//(Subscript[nμ, st[[k-1]],k->st[[k-1]]]); st=st/.k->st[[k-1]]],
{k,{i,j}}];
done=done⋃{i,j},
{c,rvk[[1]]}
];
CF/@ ζ 
], {Length@$M,$M}]
aTerm[K_]:=T((D[Alexander[K][T],T])/(((Alexander[K][T]))^2))
(Subscript[ρ, 1])[K_]:=Module[{z=Z[K][[3]],Al},Al=1/(z/.ℏ->0);((-T (Al^3))/(((T-1))^2))(Coefficient[z,ℏ]-T((D[Al,T])/(Al^2)))]//Factor

Knot table. Note how (Subscript[ρ, 1]) matches precisely with the original (Subscript[ρ, 1 ]) from the Drinfeld double.

Quiet@(Subscript[ρ, 1])/@AllKnots[{3,8}]//Column