Pensieve header: Knot Signatures as in KnotTheory` and as in Kashaev, with verifications up to 13 crossings. Continues pensieve://Talks/CMS-2112/.

Once[<< KnotTheory`]

MatrixSignature[A_]:=Total[Sign[Select[Eigenvalues[A],Abs[#]>(10^(-12))&]]];
Writhe[K_]:=Sum[If[PositiveQ[x],1,-1], {x,List@@PD@K}];

\begin{multicols}{2}

nb2tex$PDFWidth = 1.23 N[284/72];

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

The Bedlewo program

\[ \resizebox{0.8\linewidth}{!}{\import{../../Talks/CMS-2112/}{BedXings.pdf_t}} \]

Bed[K_,ω_]:=Module[{t,r,XingsByArmpits,bends,faces,p,A,is},
t=1-ω; r=t+t\[Conjugate];
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{-r, -t, 2 t, t\[Conjugate]}, {-t\[Conjugate], 0, t\[Conjugate], 0}, {2 t\[Conjugate], t, -r, -t\[Conjugate]}, {t, 0, -t, 0}})),(({{r, -t, -2 t\[Conjugate], t\[Conjugate]}, {-t\[Conjugate], 0, t\[Conjugate], 0}, {-2t, t, r, -t\[Conjugate]}, {t, 0, -t, 0}}))],
{x,XingsByArmpits}];
MatrixSignature[A] ];

Plot[Bed[K=Knot[8,2],(E^(I t))], {t,0,2π}]
PositiveQ/@(List@@PD[K])

Draw[Knot[8,2]]

Plot[Bed[Knot@"K12a422",(E^(I t))], {t,0,2π}]

\columnbreak

The Kashaev Program

\[ \resizebox{0.8\linewidth}{!}{\import{../../Talks/CMS-2112/}{KasXings.pdf_t}} \]

Kas[K_,ω_]:=Module[{u,v,XingsByArmpits,bends,faces,p,A,is},
u=Re[(ω^(1/2))]; v= Re[ω]; (* so v=2(u^2)-1 *);
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))],
{x,XingsByArmpits}];
(MatrixSignature[A]-Writhe[K])/2 ];

nb2tex$PDFWidth = 1.1 N[284/72];

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

Plot[Kas[Knot[5,1],(E^(I t))], {t,0,2π}]

\end{multicols}
\vskip -3mm \hrule \vskip -7mm
\begin{multicols}{2}

Comparisons

Sum[ω=(E^(I RandomReal[{0,2π}])); Bed[K,ω]==Kas[K,ω], {10}, {K,AllKnots[{3,10}]}]

Table[Bed[K,I],{K,AllKnots[{3,5}]}]

Table[KnotSignature[K],{K,AllKnots[{3,5}]}]

Total@Table[Bed[K,-1]==-KnotSignature[K], {K,AllKnots[{3,10}]}]

Higher Comparisons

Sum[ω=(E^(I RandomReal[{0,2π}])); Bed[K,ω]==Kas[K,ω], {10}, {K,AllKnots[{11,11}]}]

Sum[ω=(E^(I RandomReal[{0,2π}])); Bed[K,ω]==Kas[K,ω], {10}, {K,AllKnots[{12,12}]}]

Monitor[Sum[ω=(E^(I RandomReal[{0,2π}])); Bed[K,ω]==Kas[K,ω], {K,AllKnots[{13,13}]}, {i,10}],{K,i}]

Monitor[Sum[ω=(E^(I RandomReal[{0,2π}])); If[Bed[K,ω]!=Kas[K,ω],Echo[{K,ω}],True], {K,AllKnots[{14,14}]}, {i,10}],{K,i}]

Monitor[Sum[ω=(E^(I RandomReal[{0,2π}])); If[Bed[K,ω]!=Kas[K,ω],Echo[{K,ω}],True], {K,AllKnots[{15,15}]}, {i,10}],{K,i}]

NumberOfKnots[16,NonAlternating]

Monitor[Sum[ω=(E^(I RandomReal[{0,2π}])); If[Bed[K,ω]!=Kas[K,ω],Echo[{K,ω}],True], {K,AllKnots[{16,16}]}, {i,10}],{K,i}]

From https://oeis.org/A002863:

{1->0,2->0,3->1,4->1,5->2,6->3,7->7,8->21,9->49,10->165,11->552,12->2176,13->9988,14->46972,15->253293,16->1388705,17->8053393,18->48266466,19->294130458}