Pensieve header: Implementing $\Theta$ - the main notebook accompanying Talks/MonteVerita-2604.

Invariance under R3

nb2tex$TeXFileName = "Invariance.tex";

This is Theta.nb of http://drorbn.net/mv26/ap.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\MonteVerita-2604"];

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

CF[ℰ_] := Expand@Collect[ℰ,(Subscript[g, __]),F]/.F->Factor;

(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_]=-φ/2+φ (Subscript[g, 3,k,k]);

(Subscript[δ, i_,j_]):=If[i===j,1,0];
(Subscript[gR, s_,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])])
}

Proof of Reidemeister 3:

DSum[Cs___]:=Sum[(Subscript[F, 1])[c],{c,{Cs}}]+Sum[(Subscript[F, 2])[c0,c1],{c0,{Cs}},{c1,{Cs}}]
lhs=DSum[{1,j,k},{1,i,(SuperPlus[k])},{1,(SuperPlus[i]),(SuperPlus[j])},{s,m,n}]//.(Subscript[gR, 1,j,k])⋃(Subscript[gR, 1,i,(SuperPlus[k])])⋃(Subscript[gR, 1,(SuperPlus[i]),(SuperPlus[j])]);
rhs=DSum[{1,i,j},{1,(SuperPlus[i]),k},{1,(SuperPlus[j]),(SuperPlus[k])},{s,m,n}]//.(Subscript[gR, 1,i,j])⋃(Subscript[gR, 1,(SuperPlus[i]),k])⋃(Subscript[gR, 1,(SuperPlus[j]),(SuperPlus[k])]);
Simplify[lhs==rhs]

nb2tex$TeXFileName = "Program.tex";
nb2tex$PDFWidth = 4.2

The Main Program

{\red\bf The Main Program.}

Once[<<KnotTheory`; <<Rot.m; << PolyPlot.m];

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

The Trefoil, Conway, and Kinoshita-Terasaka Knots

\vskip 3mm
{\red\bf The Trefoil, Conway, and Kinoshita-Terasaka Knots.}
\parpic[r]{\parbox{15mm}{
  \includegraphics[width=15mm]{../PhuQuoc-2506/K11n34.png}
  \vskip 1mm
  \includegraphics[width=15mm]{../PhuQuoc-2506/K11n42.png}
}}

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

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

(Note that the genus of the Conway knot appears to be bigger than the genus of Kinoshita-Terasaka)

Some Torus Knots

{\red\bf Some Torus Knots.}

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

The Rank 2 Formulas

nb2tex$PDFWidth = 4.625

ℒ[(Subscript[X, i_,j_])[s_]]:=(Subscript[T, 3]^s)𝔼[CF@Plus[
(∑_(ν=1)^3)((Subscript[x, ν,i])((Subscript[p, ν,(SuperPlus[i])])-(Subscript[p, ν,i]))+(Subscript[x, ν,j])((Subscript[p, ν,(SuperPlus[j])])-(Subscript[p, ν,j]))+((Subscript[T, ν]^s)-1)(Subscript[x, ν,i])((Subscript[p, ν,(SuperPlus[i])])-(Subscript[p, ν,(SuperPlus[j])]))),
((Subscript[T, 1]^s)-1)(Subscript[p, 3,j])(Subscript[x, 1,i])((Subscript[T, 2]^s)(Subscript[x, 2,i])-(Subscript[x, 2,j])),
ϵ s((Subscript[T, 3]^s)-1)(Subscript[p, 1,j])((Subscript[p, 2,i])-(Subscript[p, 2,j]))(Subscript[x, 3,i])/((Subscript[T, 2]^s)-1),
ϵ s(1/2+(Subscript[T, 2]^s)(Subscript[p, 1,i])(Subscript[p, 2,j])(Subscript[x, 1,i])(Subscript[x, 2,i])-(Subscript[p, 1,i])(Subscript[p, 2,j])(Subscript[x, 1,i])(Subscript[x, 2,j])-(Subscript[p, 3,i])(Subscript[x, 3,i])-((Subscript[T, 2]^s)-1)(Subscript[p, 2,j])(Subscript[p, 3,i])(Subscript[x, 2,i])(Subscript[x, 3,i])+((Subscript[T, 3]^s)-1)(Subscript[p, 2,j])(Subscript[p, 3,j])(Subscript[x, 2,i])(Subscript[x, 3,i])+2 (Subscript[p, 2,j])(Subscript[p, 3,i])(Subscript[x, 2,j])(Subscript[x, 3,i])+(Subscript[p, 1,i])(Subscript[p, 3,j])(Subscript[x, 1,i])(Subscript[x, 3,j])-(Subscript[p, 2,i])(Subscript[p, 3,j])(Subscript[x, 2,i])(Subscript[x, 3,j])-(Subscript[T, 2]^s)(Subscript[p, 2,j])(Subscript[p, 3,j])(Subscript[x, 2,i])(Subscript[x, 3,j])+(((Subscript[T, 1]^s)-1)(Subscript[p, 1,j])(Subscript[x, 1,i])((Subscript[T, 2]^(2s))(Subscript[p, 2,j])(Subscript[x, 2,i])-(Subscript[T, 2]^s)(Subscript[p, 2,j])(Subscript[x, 2,j])-((Subscript[T, 2]^s)+1)((Subscript[T, 3]^s)-1)(Subscript[p, 3,j])(Subscript[x, 3,i])+(Subscript[T, 2]^s)(Subscript[p, 3,j])(Subscript[x, 3,j]))+((Subscript[T, 3]^s)-1)(Subscript[p, 3,j])(Subscript[x, 3,i])(1-(Subscript[T, 2]^s)(Subscript[p, 1,i])(Subscript[x, 1,i])+(Subscript[p, 2,i])(Subscript[x, 2,j])+((Subscript[T, 2]^s)-2)(Subscript[p, 2,j])(Subscript[x, 2,j])))/((Subscript[T, 2]^s)-1))]]

ℒ[(Subscript[C, i_])[φ_]]:=(Subscript[T, 3]^φ)𝔼[(∑_(ν=1)^3)(Subscript[x, ν,i])((Subscript[p, ν,(SuperPlus[i])])-(Subscript[p, ν,i]))+ϵ φ((Subscript[p, 3,i])(Subscript[x, 3,i])-1/2)]

The Beehive

Data51to77=(Get["C:\\drorbn\\AcademicPensieve\\Projects\\HigherRank\\DunfieldKnots\\D0"<>ToString[#]<>".m"][[2,2]]/.{T1->(Subscript[T, 1]),T2->(Subscript[T, 2])})&/@Range[51,77];

Images51to77=PolyPlot2/@Data51to77;

Show[img=0;
Beehive=Graphics[{
{0,0},{1,0},{2,0},{3,0},{4,0},
       {0,1},{1,1},{2,1},{3,1},
{-1,2},{0,2},{1,2},{2,2},{3,2},
       {-1,3},{0,3},{1,3},{2,3},
{-2,4},{-1,4},{0,4},{1,4},{2,4},
       {-2,5},{-1,5},{0,5},{1,5}
}/.{x_,y_}:>
Inset[
SetAlphaChannel[Images51to77[[++img]],Graphics[{White,Polygon[Table[{Cos[t],Sin[t]},{t,0,5π/3,π/3}]]},Background->Black]],
x{0,1}+y{(Sqrt[3])/2,1/2},Center,1.2
],
PlotRange->{{-0.6,4.91},{0,4}}, ImageSize->1200],
ImageSize->Small]

Export["Beehive.pdf",ImageCrop[Beehive]]