SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\Beijing-2407"];
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[R, 1])[1,i_,j_]=CF[
1/2-(Subscript[T, 3])(Subscript[g, 1,j,i])(Subscript[g, 2,j,i])-(Subscript[g, 3,i,i])+(Subscript[g, 2,j,j])(Subscript[g, 3,i,i])+(Subscript[T, 1])((Subscript[T, 3])-1)(Subscript[g, 1,j,i])(Subscript[g, 3,j,i])+(Subscript[T, 2])((Subscript[T, 3])-1)(Subscript[g, 2,j,i])(Subscript[g, 3,j,i])-(Subscript[T, 2])(Subscript[g, 2,j,i])(Subscript[g, 3,j,j])+((Subscript[g, 1,j,j])(Subscript[g, 2,i,i])+((Subscript[T, 3])-1)(Subscript[g, 1,j,j])(Subscript[g, 2,j,i])-(Subscript[T, 1])(Subscript[g, 1,i,i])(Subscript[g, 2,j,j])-(Subscript[g, 1,j,j])(Subscript[g, 3,i,i])-(Subscript[T, 1])((Subscript[T, 3])-1)(Subscript[g, 1,j,j])(Subscript[g, 3,j,i])+(Subscript[T, 1])(Subscript[g, 1,i,i])(Subscript[g, 3,j,j]))/((Subscript[T, 1])-1)];

Simplify[(Subscript[R, 1])[1,i,j]==(1/2)+(((Subscript[g, 1,j,j]) (Subscript[g, 2,i,i]))/(-1+(Subscript[T, 1])))-(Subscript[T, 1]) (Subscript[T, 2]) (Subscript[g, 1,j,i]) (Subscript[g, 2,j,i])+(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j,j]) (Subscript[g, 2,j,i]))/(-1+(Subscript[T, 1])))-(((Subscript[T, 1]) (Subscript[g, 1,i,i]) (Subscript[g, 2,j,j]))/(-1+(Subscript[T, 1])))-(Subscript[g, 3,i,i])-(((Subscript[g, 1,j,j]) (Subscript[g, 3,i,i]))/(-1+(Subscript[T, 1])))+(Subscript[g, 2,j,j]) (Subscript[g, 3,i,i])+(Subscript[T, 1]) (-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j,i]) (Subscript[g, 3,j,i])-(((Subscript[T, 1]) (-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j,j]) (Subscript[g, 3,j,i]))/(-1+(Subscript[T, 1])))+(Subscript[T, 2]) (-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 2,j,i]) (Subscript[g, 3,j,i])+(((Subscript[T, 1]) (Subscript[g, 1,i,i]) (Subscript[g, 3,j,j]))/(-1+(Subscript[T, 1])))-(Subscript[T, 2]) (Subscript[g, 2,j,i]) (Subscript[g, 3,j,j])]

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

(Subscript[R, 1])[-1,i,j]

Simplify[(Subscript[R, 1])[-1,i,j]==-(1/2)-(((Subscript[g, 1,j,i]) (Subscript[g, 2,i,i]))/(Subscript[T, 1]))-(((Subscript[g, 1,j,j]) (Subscript[g, 2,i,i]))/(-1+(Subscript[T, 1])))+(((Subscript[T, 1]) (-1+(Subscript[T, 2])) (Subscript[g, 1,i,i]) (Subscript[g, 2,j,i]))/((-1+(Subscript[T, 1])) (Subscript[T, 2])))-(((-(Subscript[T, 1])-(Subscript[T, 2])+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j,i]) (Subscript[g, 2,j,i]))/((Subscript[T, 1]) (Subscript[T, 2])))-(Subscript[g, 1,j,j]) (Subscript[g, 2,j,i])+(((Subscript[T, 1]) (Subscript[g, 1,i,i]) (Subscript[g, 2,j,j]))/(-1+(Subscript[T, 1])))-(Subscript[g, 1,j,i]) (Subscript[g, 2,j,j])+(Subscript[g, 3,i,i])+(((Subscript[g, 1,j,i]) (Subscript[g, 3,i,i]))/(Subscript[T, 1]))+(((Subscript[g, 1,j,j]) (Subscript[g, 3,i,i]))/(-1+(Subscript[T, 1])))-(((-1+(Subscript[T, 2])) (Subscript[g, 2,j,i]) (Subscript[g, 3,i,i]))/(Subscript[T, 2]))-(Subscript[g, 2,j,j]) (Subscript[g, 3,i,i])-(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,i,i]) (Subscript[g, 3,j,i]))/((-1+(Subscript[T, 1])) (Subscript[T, 2])))+(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j,i]) (Subscript[g, 3,j,i]))/((Subscript[T, 1]) (Subscript[T, 2])))-(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 2,i,i]) (Subscript[g, 3,j,i]))/((Subscript[T, 1]) (Subscript[T, 2])))+(((-1+2 (Subscript[T, 2])) (-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 2,j,i]) (Subscript[g, 3,j,i]))/((Subscript[T, 1]) (Subscript[T, 2]^2)))+(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 2,j,j]) (Subscript[g, 3,j,i]))/((Subscript[T, 1]) (Subscript[T, 2])))-(((Subscript[T, 1]) (Subscript[g, 1,i,i]) (Subscript[g, 3,j,j]))/(-1+(Subscript[T, 1])))+(Subscript[g, 1,j,i]) (Subscript[g, 3,j,j])+(Subscript[g, 2,j,i]) (Subscript[g, 3,j,j])]

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

Simplify[θ[{1,i0,j0},{1,i1,j1}]==-(Subscript[T, 1])(-1+(Subscript[T, 1])(Subscript[T, 2]))(Subscript[g, 1,j1,i0])(Subscript[g, 2,i1,i0])(Subscript[g, 3,j0,i1])+(-1+(Subscript[T, 1])(Subscript[T, 2]))(Subscript[g, 1,j1,j0])(Subscript[g, 2,i1,i0])(Subscript[g, 3,j0,i1])+(Subscript[T, 1])(-1+(Subscript[T, 1])(Subscript[T, 2]))(Subscript[g, 1,j1,i0])(Subscript[g, 2,j1,i0])(Subscript[g, 3,j0,i1])+(1-(Subscript[T, 1])(Subscript[T, 2]))(Subscript[g, 1,j1,j0])(Subscript[g, 2,j1,i0])(Subscript[g, 3,j0,i1])]

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

Simplify[θ[{1,i0,j0},{-1,i1,j1}]==(-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,i1,i0]) (Subscript[g, 3,j0,i1])-(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j1,j0]) (Subscript[g, 2,i1,i0]) (Subscript[g, 3,j0,i1]))/(Subscript[T, 1]))+(1-(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j1,i0]) (Subscript[g, 2,j1,i0]) (Subscript[g, 3,j0,i1])+(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (Subscript[g, 1,j1,j0]) (Subscript[g, 2,j1,i0]) (Subscript[g, 3,j0,i1]))/(Subscript[T, 1]))]

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

Simplify[θ[{-1,i0,j0},{1,i1,j1}]==(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (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]) (Subscript[T, 2])) (Subscript[g, 1,j1,j0]) (Subscript[g, 2,i1,i0]) (Subscript[g, 3,j0,i1]))/(Subscript[T, 2]))-(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (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]) (Subscript[T, 2])) (Subscript[g, 1,j1,j0]) (Subscript[g, 2,j1,i0]) (Subscript[g, 3,j0,i1]))/(Subscript[T, 2]))]

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

Simplify[θ[{-1,i0,j0},{-1,i1,j1}]==-(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (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, 1]) (Subscript[T, 2])) (Subscript[g, 1,j1,j0]) (Subscript[g, 2,i1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) (Subscript[T, 2])))+(((-1+(Subscript[T, 1]) (Subscript[T, 2])) (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, 1]) (Subscript[T, 2])) (Subscript[g, 1,j1,j0]) (Subscript[g, 2,j1,i0]) (Subscript[g, 3,j0,i1]))/((Subscript[T, 1]) (Subscript[T, 2])))]

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

We call the invariant computed $\theta$:

θ[K_]:=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,ν,α,β,gEval,c,z},
{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]; gEval[ℰ_]:=Factor[ℰ/.(Subscript[g, ν_,α_,β_]):>(G[[α,β]]/.T->(Subscript[T, ν]))];
z=gEval[(∑_(k1=1)^n)(∑_(k2=1)^n)θ[Cs[[k1]],Cs[[k2]]]];
z+=gEval[(∑_(k=1)^n)(Subscript[R, 1])@@Cs[[k]]];
z+=gEval[(∑_(k=1)^(2n))(Subscript[Γ, 1])[φ[[k]],k]];
{Δ,(Δ/.T->(Subscript[T, 1]))(Δ/.T->(Subscript[T, 2]))(Δ/.T->(Subscript[T, 3]))z}//Factor ];

nb2tex$PDFWidth/=1.25;

Some Knots

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

Expand[θ[Knot[3,1]]]

nb2tex$PDFWidth*=1.25;

PolyPlot[0]=Graphics[{}];
PolyPlot[p_]:=Module[{crs,m1,m2,maxc,minc,s,hex},
crs=CoefficientRules[(Subscript[T, 1]^(m1=-Exponent[p,(Subscript[T, 1]),Min]))(Subscript[T, 2]^(m2=-Exponent[p,(Subscript[T, 2]),Min]))p,{(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)];
hex=Table[{Cos[α],Sin[α]}/Cos[2π/12]/2, {α,2π/12,2π,2π/6}];
Graphics[crs/.({x1_,x2_}->c_):>{
If[c==0,White,Lighter[If[c>0,Red,Blue], 0.88s[Abs@c]]],
Polygon[((({{1, -1/2}, {0, (Sqrt[3])/2}})).{x1+m1,x2+m2}+#)&/@hex] }] ]

nb2tex$PDFWidth/=1.25;

\parpic[r]{$
  {\includegraphics[height=0.45in]{K11n34.png}
    \atop\text{\tiny K11n34}}
  {\includegraphics[height=0.45in]{K11n42.png}
    \atop\text{\tiny K11n42}}
$}

GraphicsRow[PolyPlot[θ[Knot[#]][[2]]]&
/@{"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!

\vskip 8mm

%\needspace{50mm}
\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 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;

AbsoluteTiming@PolyPlot[θ[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])]][[2]]]

nb2tex$PDFWidth/=1.25;

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

g250=GraphicsGrid[Partition[PolyPlot/@tab250,25],Spacings -> 0]

Export["g250.png",g250,ImageSize->2400]