Pensieve header: This is the main Mathematica package that goes along with the paper “A Very Fast, Very Strong, Topologically Meaningful and Fun Knot Invariant” by Dror Bar-Natan and Roland van der Veen.

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

We start by loading the package \verb$KnotTheory`$ --- it is only needed because it has many specific knots pre-defined:

<< KnotTheory`

Next we quietly define the commands \verb$Rot$, used to compute rotation numbers, and \verb$PolyPlot$, used to plot polynomials as bar codes and as hexagonal QR codes. Neither is a part of the core of the computation of $\Theta$, so neither is shown; yet we do show some usage examples.

(* Rot suppressed *)

Rot[pd_PD]:=Module[{n,xs,x,rots,Xp,Xm,front={1},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=1,k<=2n,++k,
If[FreeQ[front,-k],
front=Flatten@Replace[front,k->(xs/.{
Xp[k,l_]|Xm[l_,k]:>{l+1,k+1,-l},
Xp[l_,k]|Xm[k,l_]:>(++rots[[l]];{-l,k+1,l+1}),
_Xp|_Xm:>{}
}), {1}],
Cases[front,k|-k]/.{k,-k}:>--rots[[k]];
]
];
{xs/.{Xp[i_,j_]:>{+1,i,j}, Xm[i_,j_]:>{-1,i,j}},rots} ];
Rot[K_]:=Rot[PD[K]];

Rot[Mirror@Knot[3,1]]

We urge the reader to compare the above output with the knot diagram in Section~\ref{ssec:OldFormulas}.

(* PolyPlot suppressed *)

PolyPlot1[Δ_]:=Module[{crs,m,maxc,minc,s,rect},
rect={{0,0},{1,0},{1,1},{0,1}};
If[Expand[Δ]===0,Graphics[],
m=Max[-Exponent[Δ,T,Min], Exponent[Δ,T,Max]];
crs=CoefficientRules[(T^m)Δ,{T}];
maxc=N@Log@Max@Abs[Last/@crs];
minc=N@Log@Min@Select[Abs[Last/@crs],#>0&];
If[minc==maxc,s[_]=0,s[c_]:=s[c]=(maxc-Log@c)/(maxc-minc)];
Graphics[crs/.({x_}->c_):>{
Lighter[Which[c==0, White,c>0, Red,c<0,Blue], 0.88s[Abs@c]],
Tooltip[Polygon[({x+m-1/2,0}+#)&/@rect],c (T^(x-m))]
},AspectRatio->Min[1/5 ,1/(Sqrt[m+1])],ImagePadding->None,PlotRangePadding->None]
]];
Options[PolyPlot2]={Labeled->False};
PolyPlot2[θ_,OptionsPattern[]]:=Module[{crs,m1,m2,maxc,minc,s,hex,p},
If[Expand[θ]===0,Graphics[{White,Disk[]}],
hex=Table[{Cos[α],Sin[α]}/Cos[2π/12]/2, {α,2π/12,2π,2π/6}];
m1=Max[-Exponent[θ,(Subscript[T, 1]),Min], Exponent[θ,(Subscript[T, 1]),Max]];
m2=Max[-Exponent[θ,(Subscript[T, 2]),Min], Exponent[θ,(Subscript[T, 2]),Max]];
crs=CoefficientRules[(Subscript[T, 1]^m1)(Subscript[T, 2]^m2)θ,{(Subscript[T, 1]),(Subscript[T, 2])}];
maxc=N@Log@Max@Abs[Last/@crs];
minc=N@Log@Min@Select[Abs[Last/@crs],#>0&];
If[minc==maxc,s[_]=0,s[c_]:=s[c]=(maxc-Log@c)/(maxc-minc)];
Graphics[{(*{Yellow,Disk[{0,0},1+Cos[2π/12]Norm[{m1,m2}]/(Sqrt[2])]},*)
crs/.({x1_,x2_}->c_):>{
Lighter[Which[c==0, White,c>0, Red,c<0,Blue], 0.88s[Abs@c]],
p=(({{1, -1/2}, {0, (Sqrt[3])/2}})).{x1-m1,x2-m2};
Tooltip[Polygon[(p+#)&/@hex],c (Subscript[T, 1]^(x1-m1))(Subscript[T, 2]^(x2-m2))] ,
If[Not@OptionValue[Labeled],{},{Black, Text[Style[c (Subscript[T, 1]^(x1-m1))(Subscript[T, 2]^(x2-m2)),30],p]}]
}
},ImagePadding->None,PlotRangePadding->None]
]];
PolyPlot[{Δ_,θ_},opts___Rule]:=GraphicsColumn[
{PolyPlot1[Δ],PolyPlot2[θ,FilterRules[{opts},Options[PolyPlot2]]]},
Spacings -> Scaled@0.08,ImagePadding->None,PlotRangePadding->None,
FilterRules[{opts},Options[GraphicsColumn]]
];

PPDemo=PolyPlot2[2+(Subscript[T, 1])-(Subscript[T, 1])(Subscript[T, 2])+(Subscript[T, 2])-(Subscript[T, 1]^(-1))+(Subscript[T, 1]^(-1))(Subscript[T, 2]^(-1))-(Subscript[T, 2]^(-1)),Labeled->True]

Export["PPDemo.pdf",PPDemo]

1/2+(Subscript[T, 1])-(Subscript[T, 1])(Subscript[T, 2])+(Subscript[T, 2])-(Subscript[T, 1]^(-1))+(Subscript[T, 1]^(-1))(Subscript[T, 2]^(-1))-(Subscript[T, 2]^(-1))//TeXForm

PolyPlot[{T-1+(T^(-1)), (Subscript[T, 1])+2(Subscript[T, 2])-4(Subscript[T, 1]^(-1))(Subscript[T, 2]^(-1))}, ImageSize->Tiny]

We urge the reader to reflect on how the ``QR Code’’ part of the above picture corresponds to the 2-variable polynomial $T_1+2T_2-4T_1^{-1}T_2^{-1}$.

Next, we decree that $T_3=T_1T_2$ and define the three ``Feynman Diagram’’ polynomials $F_1$, $F_2$, and $F_3$ (those definitions are printed in a smaller font because they are equal to what was already printed in \eqref{eq:F1}--\eqref{eq:F3}):

(Subscript[T, 3])=(Subscript[T, 1])(Subscript[T, 2]);

CF[ℰ_] := Module[{vs=Union@Cases[ℰ,(Subscript[g, __]),∞],ps,c},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> Factor[c](Times@@(vs^ps))] ];

nb2tex$PDFWidth*=1.5

CF[s(1/2-(Subscript[g, 3,i,i])+(Subscript[T, 2]^s)(Subscript[g, 1,i,i])(Subscript[g, 2,j,i])-(Subscript[g, 1,i,i])(Subscript[g, 2,j,j])-((Subscript[T, 2]^s)-1)(Subscript[g, 2,j,i])(Subscript[g, 3,i,i])+2(Subscript[g, 2,j,j])(Subscript[g, 3,i,i])-(1-(Subscript[T, 3]^s))(Subscript[g, 2,j,i])(Subscript[g, 3,j,i])-(Subscript[g, 2,i,i])(Subscript[g, 3,j,j])-(Subscript[T, 2]^s)(Subscript[g, 2,j,i])(Subscript[g, 3,j,j])+(Subscript[g, 1,i,i])(Subscript[g, 3,j,j])+(((Subscript[T, 1]^s)-1)(Subscript[g, 1,j,i])((Subscript[T, 2]^(2s))(Subscript[g, 2,j,i])-(Subscript[T, 2]^s)(Subscript[g, 2,j,j])+(Subscript[T, 2]^s)(Subscript[g, 3,j,j]))+((Subscript[T, 3]^s)-1)(Subscript[g, 3,j,i])(1-(Subscript[T, 2]^s)(Subscript[g, 1,i,i])-((Subscript[T, 1]^s)-1)((Subscript[T, 2]^s)+1) (Subscript[g, 1,j,i])+((Subscript[T, 2]^s)-2)(Subscript[g, 2,j,j])+(Subscript[g, 2,i,j])))/((Subscript[T, 2]^s)-1))/. s->1]

(Subscript[F, 1])[{1,i_,j_}]=(1/2)+(Subscript[T, 2]) (Subscript[g, 1,i,i]) (Subscript[g, 2,j,i])+((((Subscript[T, 1])-1) (Subscript[T, 2]^2) (Subscript[g, 1,j,i]) (Subscript[g, 2,j,i]))/((Subscript[T, 2])-1))-(Subscript[g, 1,i,i]) (Subscript[g, 2,j,j])-((((Subscript[T, 1])-1) (Subscript[T, 2]) (Subscript[g, 1,j,i]) (Subscript[g, 2,j,j]))/((Subscript[T, 2])-1))-(Subscript[g, 3,i,i])+(1-(Subscript[T, 2])) (Subscript[g, 2,j,i]) (Subscript[g, 3,i,i])+2 (Subscript[g, 2,j,j]) (Subscript[g, 3,i,i])+((((Subscript[T, 3])-1) (Subscript[g, 3,j,i]))/((Subscript[T, 2])-1))-(((Subscript[T, 2]) ((Subscript[T, 3])-1) (Subscript[g, 1,i,i]) (Subscript[g, 3,j,i]))/((Subscript[T, 2])-1))-((((Subscript[T, 1])-1) ((Subscript[T, 2])+1) ((Subscript[T, 3])-1) (Subscript[g, 1,j,i]) (Subscript[g, 3,j,i]))/((Subscript[T, 2])-1))+((((Subscript[T, 3])-1) (Subscript[g, 2,i,j]) (Subscript[g, 3,j,i]))/((Subscript[T, 2])-1))+((Subscript[T, 3])-1) (Subscript[g, 2,j,i]) (Subscript[g, 3,j,i])+((((Subscript[T, 2])-2) ((Subscript[T, 3])-1) (Subscript[g, 2,j,j]) (Subscript[g, 3,j,i]))/((Subscript[T, 2])-1))+(Subscript[g, 1,i,i]) (Subscript[g, 3,j,j])+((((Subscript[T, 1])-1) (Subscript[T, 2]) (Subscript[g, 1,j,i]) (Subscript[g, 3,j,j]))/((Subscript[T, 2])-1))-(Subscript[g, 2,i,i]) (Subscript[g, 3,j,j])-(Subscript[T, 2]) (Subscript[g, 2,j,i]) (Subscript[g, 3,j,j]);

CF[s(1/2-(Subscript[g, 3,i,i])+(Subscript[T, 2]^s)(Subscript[g, 1,i,i])(Subscript[g, 2,j,i])-(Subscript[g, 1,i,i])(Subscript[g, 2,j,j])-((Subscript[T, 2]^s)-1)(Subscript[g, 2,j,i])(Subscript[g, 3,i,i])+2(Subscript[g, 2,j,j])(Subscript[g, 3,i,i])-(1-(Subscript[T, 3]^s))(Subscript[g, 2,j,i])(Subscript[g, 3,j,i])-(Subscript[g, 2,i,i])(Subscript[g, 3,j,j])-(Subscript[T, 2]^s)(Subscript[g, 2,j,i])(Subscript[g, 3,j,j])+(Subscript[g, 1,i,i])(Subscript[g, 3,j,j])+(((Subscript[T, 1]^s)-1)(Subscript[g, 1,j,i])((Subscript[T, 2]^(2s))(Subscript[g, 2,j,i])-(Subscript[T, 2]^s)(Subscript[g, 2,j,j])+(Subscript[T, 2]^s)(Subscript[g, 3,j,j]))+((Subscript[T, 3]^s)-1)(Subscript[g, 3,j,i])(1-(Subscript[T, 2]^s)(Subscript[g, 1,i,i])-((Subscript[T, 1]^s)-1)((Subscript[T, 2]^s)+1) (Subscript[g, 1,j,i])+((Subscript[T, 2]^s)-2)(Subscript[g, 2,j,j])+(Subscript[g, 2,i,j])))/((Subscript[T, 2]^s)-1))/. s->-1]

(Subscript[F, 1])[{-1,i_,j_}]=-(1/2)-(((Subscript[g, 1,i,i]) (Subscript[g, 2,j,i]))/(Subscript[T, 2]))-((((Subscript[T, 1])-1) (Subscript[g, 1,j,i]) (Subscript[g, 2,j,i]))/((Subscript[T, 1]) ((Subscript[T, 2])-1) (Subscript[T, 2])))+(Subscript[g, 1,i,i]) (Subscript[g, 2,j,j])+((((Subscript[T, 1])-1) (Subscript[g, 1,j,i]) (Subscript[g, 2,j,j]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)))+(Subscript[g, 3,i,i])-((((Subscript[T, 2])-1) (Subscript[g, 2,j,i]) (Subscript[g, 3,i,i]))/(Subscript[T, 2]))-2 (Subscript[g, 2,j,j]) (Subscript[g, 3,i,i])-((((Subscript[T, 3])-1) (Subscript[g, 3,j,i]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)))+((((Subscript[T, 3])-1) (Subscript[g, 1,i,i]) (Subscript[g, 3,j,i]))/((Subscript[T, 1]) ((Subscript[T, 2])-1) (Subscript[T, 2])))-((((Subscript[T, 1])-1) ((Subscript[T, 2])+1) ((Subscript[T, 3])-1) (Subscript[g, 1,j,i]) (Subscript[g, 3,j,i]))/((Subscript[T, 1]^2) ((Subscript[T, 2])-1) (Subscript[T, 2])))-((((Subscript[T, 3])-1) (Subscript[g, 2,i,j]) (Subscript[g, 3,j,i]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)))+((((Subscript[T, 3])-1) (Subscript[g, 2,j,i]) (Subscript[g, 3,j,i]))/(Subscript[T, 3]))+(((2 (Subscript[T, 2])-1) ((Subscript[T, 3])-1) (Subscript[g, 2,j,j]) (Subscript[g, 3,j,i]))/((Subscript[T, 1]) ((Subscript[T, 2])-1) (Subscript[T, 2])))-(Subscript[g, 1,i,i]) (Subscript[g, 3,j,j])-((((Subscript[T, 1])-1) (Subscript[g, 1,j,i]) (Subscript[g, 3,j,j]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)))+(Subscript[g, 2,i,i]) (Subscript[g, 3,j,j])+(((Subscript[g, 2,j,i]) (Subscript[g, 3,j,j]))/(Subscript[T, 2]));

CF[s1((Subscript[T, 1]^s0)-1)((((Subscript[T, 2]^s1)-1))^(-1))((Subscript[T, 3]^s1)-1)(Subscript[g, 1,j1,i0])(Subscript[g, 3,j0,i1])( ((Subscript[T, 2]^s0)(Subscript[g, 2,i1,i0])-(Subscript[g, 2,i1,j0]))- ((Subscript[T, 2]^s0)(Subscript[g, 2,j1,i0])-(Subscript[g, 2,j1,j0])))/. {s0->1,s1->1}]

(Subscript[F, 2])[{1,i0_,j0_},{1,i1_,j1_}]=((((Subscript[T, 1])-1) (Subscript[T, 2]) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 2])-1))-((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,j0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 2])-1))-((((Subscript[T, 1])-1) (Subscript[T, 2]) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 2])-1))+((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,j0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 2])-1));

CF[s1((Subscript[T, 1]^s0)-1)((((Subscript[T, 2]^s1)-1))^(-1))((Subscript[T, 3]^s1)-1)(Subscript[g, 1,j1,i0])(Subscript[g, 3,j0,i1])( ((Subscript[T, 2]^s0)(Subscript[g, 2,i1,i0])-(Subscript[g, 2,i1,j0]))- ((Subscript[T, 2]^s0)(Subscript[g, 2,j1,i0])-(Subscript[g, 2,j1,j0])))/. {s0->1,s1->-1}]

(Subscript[F, 2])[{1,i0_,j0_},{-1,i1_,j1_}]=-((((Subscript[T, 1])-1) (Subscript[T, 2]) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)))+((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,j0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)))+((((Subscript[T, 1])-1) (Subscript[T, 2]) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)))-((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,j0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)));

CF[s1((Subscript[T, 1]^s0)-1)((((Subscript[T, 2]^s1)-1))^(-1))((Subscript[T, 3]^s1)-1)(Subscript[g, 1,j1,i0])(Subscript[g, 3,j0,i1])( ((Subscript[T, 2]^s0)(Subscript[g, 2,i1,i0])-(Subscript[g, 2,i1,j0]))- ((Subscript[T, 2]^s0)(Subscript[g, 2,j1,i0])-(Subscript[g, 2,j1,j0])))/. {s0->-1,s1->1}]

(Subscript[F, 2])[{-1,i0_,j0_},{1,i1_,j1_}]=-((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) ((Subscript[T, 2])-1) (Subscript[T, 2])))+((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,j0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)))+((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) ((Subscript[T, 2])-1) (Subscript[T, 2])))-((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,j0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) ((Subscript[T, 2])-1)));

CF[s1((Subscript[T, 1]^s0)-1)((((Subscript[T, 2]^s1)-1))^(-1))((Subscript[T, 3]^s1)-1)(Subscript[g, 1,j1,i0])(Subscript[g, 3,j0,i1])( ((Subscript[T, 2]^s0)(Subscript[g, 2,i1,i0])-(Subscript[g, 2,i1,j0]))- ((Subscript[T, 2]^s0)(Subscript[g, 2,j1,i0])-(Subscript[g, 2,j1,j0])))/. {s0->-1,s1->-1}]

(Subscript[F, 2])[{-1,i0_,j0_},{-1,i1_,j1_}]=((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]^2) ((Subscript[T, 2])-1) (Subscript[T, 2])))-((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,j0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]^2) ((Subscript[T, 2])-1)))-((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]^2) ((Subscript[T, 2])-1) (Subscript[T, 2])))+((((Subscript[T, 1])-1) ((Subscript[T, 3])-1) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,j0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]^2) ((Subscript[T, 2])-1)));

(Subscript[F, 3])[φ_,k_]=φ (Subscript[g, 3,k,k])-φ/2;

nb2tex$PDFWidth/=1.5

Next comes the main program computing $\Theta$. Fortunately, it matches perfectly with the mathematical description in Section~\ref{sec:Formulas}. In line 01 we let $X$ be the list of crossings in an input knot $K$, and $\varphi$ the list of its rotation numbers, using the external program \verb$Rot$ which we have already mentions. We also let $n$ be the length of $X$, namely, the number of crossings in $K$. In line 02 we let the starting value of $A$ be the identity matrix, and then in line 03, for each crossing in $X$ we add to $A$ a $2\times 2$ block, in rows $i$ and $j$ and columns $i+1$ and $j+1$, as explain in Equation~\eqref{eq:A}. In line 04 we compute the normalized Alexander polynomial $\Delta$ as in~\eqref{eq:Delta}. In line 05 we let $G$ be the inverse of $A$. In line 06 we declare what it means to evaluate, \verb$ev$, a formula $\calE$ that may contain symbols of the form $g_{\nu\alpha\beta}$: each such symbol is to be replaced by the entry in position $\alpha,\beta$ of $G$, but with $T$ replaced with $T_\nu$. In line 07 we start computing $\theta$ by computing the first summand in~\eqref{eq:Main}, which in itself, is a sum over the crossings of the knot. In line 08 we add to $\theta$ the double sum corresponding to the second term in~\eqref{eq:Main}, and in line 09, we add the third summand of~\eqref{eq:Main}. Finally, line 10 outputs a pair: $\Delta$, and the re-normalized version of $\theta$.

Θ[K_]:=Θ[K]=Module[{X,φ,n,A,Δ,G,ev,θ},
(* 01 *) {X,φ}=Rot[K]; n=Length[X];
(* 02 *) A=IdentityMatrix[2n+1];
(* 03 *) Cases[X,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
(* 04 *) Δ=(T^((-Total[φ]-Total[X[[All,1]]])/2))Det[A];
(* 05 *) G=Inverse[A];
(* 06 *) ev[ℰ_]:=Factor[ℰ/.(Subscript[g, ν_,α_,β_]):>(G[[α,β]]/.T->(Subscript[T, ν]))];
(* 07 *) θ=ev[(∑_(k=1)^n)(Subscript[F, 1])[X[[k]]]];
(* 08 *) θ+=ev[(∑_(k1=1)^n)(∑_(k2=1)^n)(Subscript[F, 2])[X[[k1]],X[[k2]]]];
(* 09 *) θ+=ev[(∑_(k=1)^(2n))(Subscript[F, 3])[φ[[k]],k]];
(* 10 *) Factor@{Δ,(Δ/.T->(Subscript[T, 1]))(Δ/.T->(Subscript[T, 2]))(Δ/.T->(Subscript[T, 3]))θ}
];

On to examples! Starting with the trefoil knot.

Expand[Θ[Knot[3,1]]]
PolyPlot[Θ[Knot[3,1]], ImageSize -> Tiny]

Θ[Knot[3,1]]

\parpic[r]{\parbox{42mm}{
  \includegraphics[width=20mm]{figs/K11n34.png}\hfill\includegraphics[width=20mm]{figs/K11n42.png}
}}
Next are the Conway knot $11_{n34}$ and the Kinoshita-Terasaka knot $11_{n42}$. The two are mutants and famously hard to separate: they both have $\Delta=1$ (as evidenced by their one-bar bar codes below), and they have the same HOMFLY-PT polynomial and Khovanov homology. Yet their $\theta$ invariants are different. Note that the genus of the Conway knot is 3, while the genus of the Kinoshita-Terasaka knot is 2. This agrees with the apparent higher complexity of the QR code of the Conway polynomial, and with the observations in Section~\ref{sec:SandM}.

PolyPlot[Θ[Knot[#]], ImageSize->Small]& /@ {"K11n34", "K11n42"}

Torus knots have particularly nice-looking $\Theta$ invariants. Here are the torus knots $T_{13/2}$, $T_{17/3}$, $T_{13/5}$, and $T_{7/6}$:

GraphicsGrid[{
TubePlot[TorusKnot@@#]&/@{{13,2},{17,3},{13,5},{7,6}},
PolyPlot[Θ[TorusKnot@@#]]&/@{{13,2},{17,3},{13,5},{7,6}}
}]

The next line shows the computation time is seconds for the 132-crossing torus knot $T_{22/7}$ on a 2024 laptop, without actually showing the output. The output plot is in Figure~\ref{fig:T227}.

AbsoluteTiming[Θ[TorusKnot[22,7]];]

AbsoluteTiming[Θ[Mirror@TorusKnot[22,7]];]

\begin{figure}

ImageCompose[PolyPlot[Θ[TorusKnot[22,7]],ImageSize->720],
TubePlot[TorusKnot[22,7],ImageSize->360],{Right,Bottom},{Right,Bottom}]

\caption{The 132-crossing torus knot $T_{22/7}$ and a plot of its $\Theta$ invariant} \label{fig:T227}
\end{figure}

tab250={{1,0}}~Join~Table[Θ[K], {K,AllKnots[{3,10}]}];

g250=GraphicsGrid[Partition[PolyPlot/@tab250,10],Spacings -> 0,Dividers->All,ImagePadding->None,PlotRangePadding->None]

Export["Theta4Rolfsen.pdf",g250]

See also https://drorbn.net/AcademicPensieve/Projects/HigherRank/DunfieldKnots/.

DunfieldKnots=ReadList["../../People/Dunfield/nmd_random_knots"]/.k_Integer:>k+1;
DK[n_]:=DunfieldKnots[[n-2]];

AbsoluteTiming[th=Θ[DK[50]];]
PolyPlot[th]

Proof of R3

nb2tex$TeXFileName = "Invariance-R3.tex";

First, we implement the Kronecker $\delta$-function, the $g$-rules for a crossing $(s,i,j)$, and the $g$-rules for a list of crossings $X$:

(Subscript[δ, i_,j_]):=If[i===j,1,0];
gRules[{s_Integer,i_,j_}]:={
(Subscript[g, ν_,j,β_]):>(Subscript[g, ν,(SuperPlus[j]),β])+(Subscript[δ, j,β]),(Subscript[g, ν_,i,β_]):>(Subscript[T, ν]^s)(Subscript[g, ν,(SuperPlus[i]),β])+(1-(Subscript[T, ν]^s))(Subscript[g, ν,(SuperPlus[j]),β])+(Subscript[δ, i,β]),
(Subscript[g, ν_,α_,(SuperPlus[i])]):>(Subscript[T, ν]^s)(Subscript[g, ν,α,i])+(Subscript[δ, α,(SuperPlus[i])]),(Subscript[g, ν_,α_,(SuperPlus[j])]):>(Subscript[g, ν,α,j])+(1-(Subscript[T, ν]^s))(Subscript[g, ν,α,i])+(Subscript[δ, α,(SuperPlus[j])])
};
gRules[{X___List}]:=Union@@Table[gRules[c],{c,{X}}]

We then let \verb$Xl$ be the three crossings in the left-hand-side of the R3 move, as in Figure~\ref{fig:R3}, we let \verb$Al$ be the $A^l$ term of~\eqref{eq:ABC}, and we let \verb$lhs$ be the result of applying the $g$-rules for the crossings in \verb$Xl$ to \verb$Al$. We print only a ``\verb$Short$’’ version of \verb$lhs$ because the full thing would cover about 2.5 pages:

Xl={{1,j,k},{1,i,(SuperPlus[k])},{1,(SuperPlus[i]),(SuperPlus[j])}};
Al=Sum[(Subscript[F, 1])[c],{c,Xl}] + Sum[(Subscript[F, 2])[c0,c1],{c0,Xl},{c1,Xl}];
lhs=Simplify[Al//.gRules[Xl]];
Short[lhs,5]

We do the same for $A^r$, except this time, without printing at all:

Xr={{1,i,j},{1,(SuperPlus[i]),k},{1,(SuperPlus[j]),(SuperPlus[k])}};
Ar=Sum[(Subscript[F, 1])[c],{c,Xr}] + Sum[(Subscript[F, 2])[c0,c1],{c0,Xr},{c1,Xr}];
rhs=Simplify[Ar//.gRules[Xr]];

We then compare \verb$lhs$ with \verb$rhs$. The output, \verb$True$, tells us that we have proven~\eqref{eq:R3A}:

Simplify[lhs==rhs]

We show that $B^l=B^r$ by following exactly the same procedure. Note that we ignore the summation over $c_y$ and instead treat it as fixed. If an equality is proven for every fixed $c_y$, it is of course also proven for the sum over $c_y\in Y$. Note also that we repeat the test twice, for the two choices of the sign of $c_y$:

Table[
cy={s,m,n};
lhs=Sum[(Subscript[F, 2])[c0,cy],{c0,Xl}]//.gRules[Xl];
rhs=Sum[(Subscript[F, 2])[c0,cy],{c0,Xr}]//.gRules[Xr];
Simplify[lhs==rhs],
{s,{1,-1}}
]

Similarly we prove that $C^l=C^r$, and this concludes the proof of Proposition~\ref{prop:R3}.

Table[
cy={s,m,n};
lhs=Sum[(Subscript[F, 2])[cy,c1],{c1,Xl}]//.gRules[Xl];
rhs=Sum[(Subscript[F, 2])[cy,c1],{c1,Xr}]//.gRules[Xr];
Simplify[lhs==rhs],
{s,{1,-1}}
]

\ \qed

\begin{remark} \label{rem:E} The computations above were carried out for generic $g_{\nu\alpha\beta}$ and for a generic $c_y=(s,m,n)$; namely, without specifying the knot diagrams in full, and hence without assigning specific values to $g_{\nu\alpha\beta}$, and without specifying $m$ and $n$. Under these conditions the three parts of~\eqref{eq:ABC} cannot mix (namely, terms from, say, $A^h$ cannot cancel terms in $B^h$ or $C^h$), and so it would have been enough to show that $E^l=E^r$, where $E^h$ combines $A^h$ and $B^h$ and $C^h$ (and a few harmless further terms) by adding $c_y$ to the summation corresponding to $A^h$:
\[
  E^h = \sum_{c\in\{c^h_{1,2,3,y}\}} F^h_1(c)
    + \sum_{c_0,c_1\in\{c^h_{1,2,3,y}\}} F^h_2(c_0,c_1).
\]
But that’s a simpler computation:

ESum[X_]:=(Sum[(Subscript[F, 1])[c],{c,X}]+Sum[(Subscript[F, 2])[c0,c1],{c0,X},{c1,X}])//.gRules[X];

Xl={{1,j,k},{1,i,(SuperPlus[k])},{1,(SuperPlus[i]),(SuperPlus[j])}};
Xr={{1,i,j},{1,(SuperPlus[i]),k},{1,(SuperPlus[j]),(SuperPlus[k])}};
Table[
Simplify[ESum[Append[Xl,{s,m,n}]]==ESum[Append[Xr,{s,m,n}]]],
{s,{1,-1}}
]

\end{remark}

Proof of R2c

nb2tex$TeXFileName = "Invariance-R2c.tex";

X={{-1,i,(SuperPlus[j])},{1,(SuperPlus[i]),j},{1,m,n}};
Simplify[ESum[X]]