SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\Bonn-2505"];
Once[<<IType.m];
(Subscript[T, 3])=(Subscript[T, 1])(Subscript[T, 2]);

nb2tex$PDFWidth*=1.25;

The Programs

{\red\bf A faster program,} in which the Feynman diagrams are ``pre-computed’’ (see theta.nb at \web{ap}):

(Subscript[F, 1])[{s_,i_,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))]

(Subscript[F, 2])[{s0_,i0_,j0_},{s1_,i1_,j1_}]:=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])))]

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

We call the invariant computed $\theta$:

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

nb2tex$PDFWidth/=1.25;

Some Knots

\needspace{15mm}
{\bf\red Some Knots.}

Expand[Θ[Knot[3,1]]]

(* PolyPlot suppressed *)

Options[PolyPlot1]={Labeled->False};PolyPlot1[Δ_,OptionsPattern[]]:=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))],
If[Not@OptionValue[Labeled],{},{Black, FontSize->Scaled[(1/((m+1)(6+maxc)))],Text[c (T^(x-m)),{x+m,0.5}]}]
},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, FontSize->Scaled[(1/(Max[m1,m2](10+maxc)))],Text[c (Subscript[T, 1]^(x1-m1))(Subscript[T, 2]^(x2-m2)),p]}]
}
},ImagePadding->None,PlotRangePadding->None]
]];
PolyPlot[{Δ_,θ_},opts___Rule]:=GraphicsColumn[
{PolyPlot1[Δ,FilterRules[{opts},Options[PolyPlot1]]],
PolyPlot2[θ,FilterRules[{opts},Options[PolyPlot2]]]},
Spacings -> Scaled@0.08,ImagePadding->None,PlotRangePadding->None,
FilterRules[{opts},Options[GraphicsColumn]]
];

\needspace{25mm}
\parpic[r]{$
  {\includegraphics[height=0.5in]{../Beijing-2407/K11n34.png}
    \atop\text{\tiny K11n34}}
  {\includegraphics[height=0.5in]{../Beijing-2407/K11n42.png}
    \atop\text{\tiny K11n42}}
$}

GraphicsRow[PolyPlot[Θ[Knot[#]],
Labeled->True]&
/@{"3_1","K11n34","K11n42"}]

\parpic[r]{$
  {\includegraphics[height=0.6in]{../../Projects/Gallery/Conway.png}
    \atop\text{\scriptsize Conway}}
  {\includegraphics[height=0.6in]{../../Projects/Gallery/PhotoNotAvailable.png}
    \atop\text{\scriptsize Kinoshita}}
  {\includegraphics[height=0.6in]{../../Projects/Gallery/Terasaka.jpg}
    \atop\text{\scriptsize Terasaka}}
$}
So $\theta$ detects knot mutation and separates the Conway knot K11n34 from the Kinoshita-Terasaka knot K11n42!

GraphicsRow[ImageCompose[
PolyPlot[Θ[TorusKnot@@#], ImageSize->480],
TubePlot[TorusKnot@@#,ImageSize->240],
{Right,Bottom},{Right,Bottom}
]&/@{{13,2},{17,3},{13,5},{7,6}}]

The torus knot $T_{22/7}$:
\newline\includegraphics[width=\linewidth]{T227.pdf}

\needspace{5cm}
Next, a random 300 crossing knot from~\cite{DHOEBL:Random} (more\newline
at \web{DK}):
\[ \includegraphics[width=0.8\linewidth]{../UBC-241004/DK300.pdf} \]

\newcolumn
{\red\bf Unproven Fact.} For any knot $K$, twice its genus $g(K)$ bounds the $T_1$ degree of $\theta$: $\deg_{T_1}\theta(K)\leq 2g(K)$.
\parpic[r]{$
  {\includegraphics[height=0.6in]{../../Projects/Gallery/Gompf.jpg}
    \atop\text{\scriptsize Gompf}}
  {\includegraphics[height=0.6in]{../../Projects/Gallery/Scharlemann.jpg}
    \atop\text{\scriptsize Scharlemann}}
  {\includegraphics[height=0.6in]{../../Projects/Gallery/Thompson.jpg}
    \atop\text{\scriptsize Thompson}}
$}
The 48-crossing Gompf-Scharlemann-Thompson $\mathit{GST}_{48}$ knot \cite{GompfScharlemannThompson:Counterexample} is significant because it may be a counterexample to the slice-ribbon conjecture:

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

nb2tex$PDFWidth*=1.25;

(Subscript[GST, 48])=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])];
AbsoluteTiming[PolyPlot[(Subscript[Θ, 48])=Θ@(Subscript[GST, 48]), ImageSize->Small]]

{Exponent[(Subscript[Θ, 48])[[1]],T],Floor[Exponent[(Subscript[Θ, 48])[[2]],(Subscript[T, 2])] /2]}

\vfill\hfill So $\Theta$ knows things about $\mathit{GST}_{48}$ that $\Delta$ doesn’t!

nb2tex$PDFWidth/=1.25;