Pensieve header: Mathematica notebook for A Perturbed Alexander Invariant.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\APerturbedAlexanderInvariant"];

Two of the main reasons we like $\rho_1$ is that it is very easy to implement and even an unsophisticated implementation runs very fast. To highlight these points we include a full implementation here, a step-by-step run-through, and a demo run. We write in Mathematica~\cite{Wolfram:Mathematica}, and you can find the notebook displayed here at~\cite[APAI.nb]{Self}.

We start by loading the library \verb$KnotTheory`$~\cite{Bar-NatanMorrison:KnotTheory} (it is used here only for the list of knots that it contains, and to compute other invariants for comparisons). We also load minor conversion routine~\cite[RVK.nb / RVK.m]{Self} whose internal workings are simple and yet irrelevant here.

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

\subsection{The Program} This done, here is the full $\rho_1$ program:

ρ[K_]:=ρ[K]=Module[{Cs,r,n,B,A,c,s,i,j,Δ,G,g,ρ1},
{Cs,r}=List@@RVK[K]; n=Length[Cs]; B=Table[0,2n,2n+1];
Do[{s,i,j}=c;B[[{i,j},{i,j,i+1,j+1}]]=(({{1, 0, -1, 0}, {0, 1, (T^s)-1, -(T^s)}})),{c,Cs}];
A=B[[All,2;;]];
Δ=(T^((Total[r]-Total[First/@Cs])/2))Det[A];
G=Prepend[Table[0,2n]][Inverse[A]]; (Subscript[g, α_,β_]):=G[[α,β]];
ρ1=(Δ^2)Sum[{s,i,j}=c;s((1-(T^s))(Subscript[g, i,j])((Subscript[g, i,j])-(Subscript[g, j,j]))+2(Subscript[g, i,i])(Subscript[g, i,j])-(Subscript[g, i,j])(Subscript[g, j,i])-(Subscript[g, i,i])(Subscript[g, j,j])-(Subscript[g, i,j])+(Subscript[g, j,j])-1/2),{c,Cs}];
ρ1+=(Δ^2)Sum[r[[k]]((Subscript[g, k,k])-1/2),{k,2n}] ;
Factor@{Δ,ρ1}];

The program uses mostly the same symbols as the text, so even without any knowledge of Mathematica, the reader should be able to recognize at least formulas~\eqref{eq:B}, \eqref{eq:Delta}, and~\eqref{eq:rho1} within it. As a further hint we add that the variables \verb$Cs$ ends up storing the list of crossing in a knot $K$, where each crossing is stored as a triple $\{s,i,j\}$, where $s$, $i$, and $j$ have the same meaning as in~\eqref{eq:B}. The conversion routine \verb$RVK$ automatically produces \verb$Cs$, as well as a list \verb$r$ of rotation numbers, given any other knot presentation known to the package \verb$KnotTheory`$.

Note that the program outputs the ordered pair $(\Delta,\rho_1)$. The Alexander polynomial $\Delta$ is anyway computed internally, and we consider the aggregate $(\Delta,\rho_1)$ as more interesting than any of its pieces by itself.

\subsection{A Step-by-Step Run-Through}  We start by setting $K$ to be the knot diagram on page~1 using the \verb$PD$ notation of \verb$KnotTheory`$. We then print \verb$RVK[K]$, which is a list of crossings followed by a list of rotation numbers:

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

Next we set \verb$Cs$ and \verb$r$ to be the list of crossings, and the list of rotation numbers, respectively.

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

We set \verb$n$ to be the number of crossings, \verb$B$ to be the zero matrix of dimensions $2n\times(2n+1)$, and then we iterate over \verb$c$ in \verb$Cs$,  adding a block as in~\eqref{eq:B} for each crossings.

n=Length[Cs]; B=Table[0,2n,2n+1];
Do[{s,i,j}=c;B[[{i,j},{i,j,i+1,j+1}]]=(({{1, 0, -1, 0}, {0, 1, (T^s)-1, -(T^s)}})),{c,Cs}];

Here’s what \verb$B$ comes out to be:

B//MatrixForm

Here’s the same, in TeXForm:

B//MatrixForm//TeXForm

Next we set \verb$A$ to be the matrix whose rows are \verb$All$ the rows of \verb$B$, and whose columns are the columns of \verb$B$ starting from column 2. We set $\Delta$ to be the determinant of \verb$A$, with a correction as in~\eqref{eq:Delta}. So $\Delta$ is the Alexander polynomial of $K$.

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

\verb$G$ is now the \verb$Inverse$ of \verb$A$ with a row of $0$’s added at the start. We set ${\mathtt g}_{\alpha\beta}$ to be the matrix entries of \verb$G$, and print \verb$G$:

G=Prepend[Table[0,2n]][Inverse[A]]; (Subscript[g, α_,β_]):=G[[α,β]];
G//MatrixForm

Here’s the same, in TeXForm:

G//MatrixForm//TeXForm

It remains to blindly follow the two parts of Equation~\eqref{eq:rho1}:

ρ1=(Δ^2)Sum[{s,i,j}=c;s((1-(T^s))(Subscript[g, i,j])((Subscript[g, i,j])-(Subscript[g, j,j]))+2(Subscript[g, i,i])(Subscript[g, i,j])-(Subscript[g, i,j])(Subscript[g, j,i])-(Subscript[g, i,i])(Subscript[g, j,j])-(Subscript[g, i,j])+(Subscript[g, j,j])-1/2),{c,Cs}]

ρ1+=(Δ^2)Sum[r[[k]]((Subscript[g, k,k])-1/2),{k,2n}]

And to output both $\Delta$ and $\rho_1$. We factor them just to put them in a nicer form:

Factor@{Δ,ρ1}

\subsection{A Demo Run}  Here are $\Delta$ and $\rho_1$ of all the knots with up to 6 crossings:

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

\begin{figure}
\[ \resizebox{6in}{!}{\input{GST48-Marked.pdf_t}} \]
\caption{A 48-crossing knot from~\cite{GompfScharlemannThompson:Counterexample}.} \label{fig:GST48}
\end{figure}
Next is one of our favourites, a knot from~\cite{GompfScharlemannThompson:Counterexample} (see Figure~\ref{fig:GST48}), which is a potential counterexample to the ribbon$=$slice conjecture. It takes about one minute to compute $\rho_1$ for this 48 crossing knot (note that Mathematica prints \verb$Timing$ information is seconds):

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

Timing@Jones[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])]][q]/. P[1,97]->1+q

The knot below was taken from the Dunfield list; its EPD presentation was computed at GST48.nb:

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

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

Length[AllKnots[{3,13}]]

Timing[Length@Union[ρ/@AllKnots[{3,10}]]]

Timing[Length@Union[{Kh[PD@#][q,t],HOMFLYPT[PD@#][a,z]}&/@AllKnots[{3,10}]]]

Monitor[Timing[Tallyρ13=Tally[Last/@Tally@Table[ρ[K],{K,AllKnots[{3,13}]}]]], K]

Total[Times@@@Rest[Tallyρ13]]

Monitor[Timing[TallyHKh13=Tally[Last/@Tally@Table[{Kh[PD@K][q,t],HOMFLYPT[PD@K][a,z]},{K,AllKnots[{3,13}]}]]], K]

Total[Times@@@Rest[TallyHKh13]]

{NumberOfKnots[14,Alternating],NumberOfKnots[14,NonAlternating]}

Monitor[Timing[Tallyρ14=Tally[Last/@Tally@Table[ρ[K],{K,AllKnots[{3,14}]}]]], K]

Monitor[Timing[TallyHKh14=Tally[Last/@Tally@Table[{Kh[PD@K][q,t],HOMFLYPT[PD@K][a,z]},{K,AllKnots[{3,14}]}]]], K]

{Total[Times@@@Rest[Tallyρ14]], Total[Times@@@Rest[TallyHKh14]]}

K=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])];
Echo@ρ[K];
Do[Echo[i->ρ[ReplacePart[K,i->(K[[i]]/.{(Subscript[X, α_,β_]):>(Subscript[(OverBar[X]), β,α]),(Subscript[(OverBar[X]), α_,β_]):>(Subscript[X, β,α])})]]],{i,Length[K]}]