Pensieve header: Implementing $\rho_1$.

Preliminaries

This is Rho1.nb of http://drorbn.net/j22/ap.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\Geneva-2206"];

Once[<<KnotTheory`; <<Rot.m];

The Program

(Subscript[R, 1])[s_,i_,j_]:=s((Subscript[g, j,i])((Subscript[g, j+1,j])+(Subscript[g, j,j+1])-(Subscript[g, i,j]))-(Subscript[g, i,i])((Subscript[g, j,j+1])-1)-1/2);
ρ[K_]:=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,ρ1},
{Cs,φ}=Rot[K]; n=Length[Cs];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
Δ=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A];
G=Inverse[A];
ρ1=(∑_(k=1)^n)(Subscript[R, 1])@@Cs[[k]] - (∑_(k=1)^(2n))φ[[k]]((Subscript[g, k,k])-1/2);
Factor@{Δ,(Δ^2)ρ1/.(Subscript[g, α_,β_]):>G[[α,β]]}];

The First Few Knots

Table[K->ρ[K], {K,AllKnots[{3,6}]}]

\def\nbpdfText#1{\vskip -3mm\[ \includegraphics[width=0.4\linewidth]{#1}\quad p=1-T^s \]}

\def\nbpdfText#1{\vskip 1mm\par\noindent\includegraphics{#1}}

\needspace{2in}

Fast!

\[ \resizebox{\linewidth}{!}{\import{../Waco-2203/}{GST48-Marked.pdf_t}} \]

Timing@ρ[EPD[(Subscript[X, 14,1]),(Subscript[(OverBar[X]), 2,29]),(Subscript[X, 3,40]),(Subscript[X, 43,4]),(Subscript[(OverBar[X]), 26,5]),(Subscript[X, 6,95]),(Subscript[X, 96,7]),(Subscript[X, 13,8]),(Subscript[(OverBar[X]), 9,28]),(Subscript[X, 10,41]),(Subscript[X, 42,11]),(Subscript[(OverBar[X]), 27,12]),(Subscript[X, 30,15]),(Subscript[(OverBar[X]), 16,61]),(Subscript[(OverBar[X]), 17,72]),(Subscript[(OverBar[X]), 18,83]),(Subscript[X, 19,34]),(Subscript[(OverBar[X]), 89,20]),(Subscript[(OverBar[X]), 21,92]),(Subscript[(OverBar[X]), 79,22]),(Subscript[(OverBar[X]), 68,23]),(Subscript[(OverBar[X]), 57,24]),(Subscript[(OverBar[X]), 25,56]),(Subscript[X, 62,31]),(Subscript[X, 73,32]),(Subscript[X, 84,33]),(Subscript[(OverBar[X]), 50,35]),(Subscript[X, 36,81]),(Subscript[X, 37,70]),(Subscript[X, 38,59]),(Subscript[(OverBar[X]), 39,54]),(Subscript[X, 44,55]),(Subscript[X, 58,45]),(Subscript[X, 69,46]),(Subscript[X, 80,47]),(Subscript[X, 48,91]),(Subscript[X, 90,49]),(Subscript[X, 51,82]),(Subscript[X, 52,71]),(Subscript[X, 53,60]),(Subscript[(OverBar[X]), 63,74]),(Subscript[(OverBar[X]), 64,85]),(Subscript[(OverBar[X]), 76,65]),(Subscript[(OverBar[X]), 87,66]),(Subscript[(OverBar[X]), 67,94]),(Subscript[(OverBar[X]), 75,86]),(Subscript[(OverBar[X]), 88,77]),(Subscript[(OverBar[X]), 78,93])]]

Strong!

{NumberOfKnots[{3,12}],
Length@Union@Table[ρ[K],{K,AllKnots[{3,12}]}],
Length@Union@Table[{HOMFLYPT[K], Kh[K]},{K,AllKnots[{3,12}]}]}

2977-{2882,2785}

So the pair $(\Delta,\rho_1)$ attains 2,882 distinct values on the 2,977 prime knots with up to 12 crossings (a deficit of 95), whereas the pair (HOMFLYPT, Khovanov Homology) attains only 2,785 distinct values on the same knots (a deficit of 192).

\def\nbpdfText#1{\vskip 1mm\par\noindent\includegraphics[width=\linewidth]{#1}}

({{, , , , , , , , }, {Hoste, Ocneanu, Millett, Freyd, Lickorish, Yetter, Przytycki, Traczyk, Khovanov}})

\def\nbpdfText#1{\vskip 1mm\par\noindent\includegraphics{#1}}

Invariance under R3

nb2tex$TeXFileName = "Invariance.tex";

(Subscript[δ, i_,j_]):=If[i==j,1,0];
(Subscript[gRules, s_,i_,j_]):={(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(T^s)(Subscript[g, i+1,β])+(1-(T^s))(Subscript[g, j+1,β]),
(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(Subscript[g, j+1,β]),(Subscript[g, α_,i]):>(T^(-s))((Subscript[g, α,i+1])-(Subscript[δ, α,i+1])),
(Subscript[g, α_,j]):>(Subscript[g, α,j+1])-(1-(T^s))(Subscript[g, α,i])-(Subscript[δ, α,j+1])}

Proof of Reidemeister 3:

lhs=(Subscript[R, 1])[1,20,30]+(Subscript[R, 1])[1,10,31]+(Subscript[R, 1])[1,11,21]//.(Subscript[gRules, 1,20,30])⋃(Subscript[gRules, 1,10,31])⋃(Subscript[gRules, 1,11,21]);
rhs=(Subscript[R, 1])[1,10,20]+(Subscript[R, 1])[1,11,30]+(Subscript[R, 1])[1,21,31]//.(Subscript[gRules, 1,10,20])⋃(Subscript[gRules, 1,11,30])⋃(Subscript[gRules, 1,21,31]);
Simplify[lhs==rhs]

Next comes Reid1, where we use results from an earlier example:

(({{1, (T^(-1)), 1}, {0, (T^(-1)), 1}, {0, 0, 1}}))//Inverse//MatrixForm

(Subscript[R, 1])[1,2,1]-1((Subscript[g, 2,2])-1/2) /. (Subscript[g, α_,β_]):>(({{1, (T^(-1)), 1}, {0, (T^(-1)), 1}, {0, 0, 1}}))[[α,β]]

Invariance under the other moves is proven similarly.

Timing@ρ[EPD[(Subscript[X, 20,1]),(Subscript[(OverBar[X]), 18,3]),(Subscript[X, 25,4]),(Subscript[(OverBar[X]), 12,5]),(Subscript[X, 21,8]),(Subscript[(OverBar[X]), 17,10]),(Subscript[X, 26,11]),(Subscript[(OverBar[X]), 30,13]),(Subscript[(OverBar[X]), 28,15]),(Subscript[(OverBar[X]), 7,16]),(Subscript[X, 24,19]),(Subscript[X, 9,22]),(Subscript[X, 2,23]),(Subscript[X, 6,27]),(Subscript[(OverBar[X]), 14,29])]]

Timing@ρ[EPD[(Subscript[(OverBar[X]), 9,2]),(Subscript[(OverBar[X]), 19,4]),(Subscript[X, 12,5]),(Subscript[(OverBar[X]), 1,8]),(Subscript[(OverBar[X]), 20,11]),(Subscript[X, 26,13]),(Subscript[X, 7,14]),(Subscript[X, 22,15]),(Subscript[(OverBar[X]), 10,17]),(Subscript[(OverBar[X]), 3,18]),(Subscript[X, 24,21]),(Subscript[X, 16,23]),(Subscript[(OverBar[X]), 6,25])]]

K=PD[X[4,2,5,1],X[2,6,3,5],X[6,4,7,3]];

{Cs,r}=List@@RVK[K]

n=Length[Cs]

A=IdentityMatrix[2n+1]

Do[{s,i,j}=c;A[[{i,j},{i+1,j+1}]]=(({{-(T^s), (T^s)-1}, {0, -1}})),{c,Cs}]

A//MatrixForm

A//MatrixForm//TeXForm

Δ=(T^((-Total[r]-Total[First/@Cs])/2))Det[A]

G=Inverse[A];

G//MatrixForm

G//Simplify//MatrixForm

G//Simplify//MatrixForm//TeXForm