Pensieve header: A $\theta$ program with Roland’s choice of Feynman diagrams.

Loading Pre-Computed Data

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\HigherRank"];
Once[<<KnotTheory`];
<<Rot.m

CCF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[ℰ];
CCF[ℰ_] := Factor[ℰ];
CF[ℰ_List]:=CF/@ℰ;
CF[ℰ_] := Module[{vs=Cases[ℰ,(Subscript[(x|p|π|g), __]),∞]⋃{x,p,ϵ},ps,c},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))] ];

(Subscript[R, 1])[s_,i_,j_]:=CF[
s((Subscript[T, 2]^s) (Subscript[g, 1,i,i]) (Subscript[g, 2,j,i])+(((-1+(Subscript[T, 1]^s)) (Subscript[T, 2]^(2 s)) (Subscript[g, 1,j,i]) (Subscript[g, 2,j,i]))/(-1+(Subscript[T, 2]^s)))-(Subscript[g, 1,i,i]) (Subscript[g, 2,j,j])-(((-1+(Subscript[T, 1]^s)) (Subscript[T, 2]^s) (Subscript[g, 1,j,i]) (Subscript[g, 2,j,j]))/(-1+(Subscript[T, 2]^s)))-(Subscript[g, 3,i,i])-(-1+(Subscript[T, 2]^s)) (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, 3,j,i]))/(-1+(Subscript[T, 2]^s)))-(((Subscript[T, 2]^s) (-1+(Subscript[T, 3]^s) ) (Subscript[g, 1,i,i]) (Subscript[g, 3,j,i]))/(-1+(Subscript[T, 2]^s)))-(((-1+(Subscript[T, 1]^s)) (1+(Subscript[T, 2]^s)) (-1+(Subscript[T, 3]^s) ) (Subscript[g, 1,j,i]) (Subscript[g, 3,j,i]))/(-1+(Subscript[T, 2]^s)))+(((-1+(Subscript[T, 3]^s) ) (Subscript[g, 2,i,j]) (Subscript[g, 3,j,i]))/(-1+(Subscript[T, 2]^s)))-(1-(Subscript[T, 3]^s) ) (Subscript[g, 2,j,i]) (Subscript[g, 3,j,i])+(((-2+(Subscript[T, 2]^s)) (-1+(Subscript[T, 3]^s) ) (Subscript[g, 2,j,j]) (Subscript[g, 3,j,i]))/(-1+(Subscript[T, 2]^s)))+(Subscript[g, 1,i,i]) (Subscript[g, 3,j,j])+(((-1+(Subscript[T, 1]^s)) (Subscript[T, 2]^s) (Subscript[g, 1,j,i]) (Subscript[g, 3,j,j]))/(-1+(Subscript[T, 2]^s)))-(Subscript[g, 2,i,i]) (Subscript[g, 3,j,j])-(Subscript[T, 2]^s) (Subscript[g, 2,j,i]) (Subscript[g, 3,j,j])+(1/2))];
(Subscript[Γ, 1])[φ_,k_]:=CF[-(φ/2)+φ (Subscript[g, 3,k,k])];
θ[{s1_,i1_,j1_},{s2_,i2_,j2_}]:=CF[
(1/(-1+(Subscript[T, 2]^s2)))s2 (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s2)) ((-1+(Subscript[T, 1]^s1)) (Subscript[g, 1,j2,i1]) ((Subscript[T, 2]^s1) (Subscript[g, 2,i2,i1])-(Subscript[g, 2,i2,j1])) (Subscript[g, 3,j1,i2])-(-1+(Subscript[T, 1]^s1)) (Subscript[g, 1,j2,i1]) ((Subscript[T, 2]^s1) (Subscript[g, 2,j2,i1])-(Subscript[g, 2,j2,j1])) (Subscript[g, 3,j1,i2]))]

The Programs

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

(Subscript[θ, T1_,T2_])[K_]:=(Subscript[θ, T1,T2])[K]=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,gEval,Y,yEval,c,z=0},
{Cs,φ}=Rot[K]; n=Length[Cs];
temp0=PrintTemporary["At work, n=",n];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
Δ[0]:=Δ[0]=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A];
G[0]:=G[0]=Inverse[A];
{Δ[1],G[1]}=If[NumberQ@T1,
{Det[A/.T->T1],Inverse[A/.T->T1]},{Δ[0],G[0]}/.T->T1 ];
temp=PrintTemporary@"Done with {Δ[1],G[1]}.";
{Δ[2],G[2]}=If[NumberQ@T2,
{Det[A/.T->T2],Inverse[A/.T->T2]},{Δ[0],G[0]}/.T->T2 ];
NotebookDelete[temp]; temp=PrintTemporary@"Done with {Δ[2],G[2]}.";
{Δ[3],G[3]}=If[NumberQ[T1 T2],
{Det[A/.T->T1 T2],Inverse[A/.T->T1 T2]},{Δ[0],G[0]}/.T->T1 T2 ];
NotebookDelete[temp]; temp=PrintTemporary@"Done with {Δ[3],G[3]}.";
gEval[ℰ_]:=CCF[ℰ//.{(Subscript[T, 1])->T1,(Subscript[T, 2])->T2,(Subscript[g, ν_,α_,β_]):>G[ν][[α,β]]}];
Do[z+=gEval[θ[Cs[[k1]],Cs[[k2]]]],{k1,n},{k2,n}];
Do[z+=gEval[(Subscript[R, 1])@@Cs[[k]]],{k,n}];
Do[z+=gEval[(Subscript[Γ, 1])[φ[[k]],k]],{k,2n}];
NotebookDelete[temp0];NotebookDelete[temp];
{{Δ[1],Δ[2],Δ[3]},Δ[1]Δ[2]Δ[3]z}//CCF
];

TestSymmetries[K_]:=Module[{θ0,θ1},
{θ0,θ1}={θ[K][[2]],θ[Mirror@K][[2]]};
Simplify@And[
θ0==(θ0/.{(Subscript[T, 1])->(Subscript[T, 2]),(Subscript[T, 2])->(Subscript[T, 1])}),
θ0==-θ1,
θ0==(θ0/.(Subscript[T, i_]):>(Subscript[T, i]^(-1))),
θ0==(θ0/.(Subscript[T, 2])->(Subscript[T, 1]^(-1))(Subscript[T, 2]^(-1)))
]
]

hex=Table[{Cos[α],Sin[α]}/Cos[2π/12]/2, {α,2π/12,2π,2π/6}];
(Subscript[PolyPlot, __])[0]=Graphics[{}];
(Subscript[PolyPlot, T1_,T2_])[p_]:=(Subscript[PolyPlot, Hexagon,T1,T2])[p]
(Subscript[PolyPlot, shape_,T1_,T2_])[p_]:=Module[{crs,m1,m2,maxc,minc,s},
crs=CoefficientRules[(T1^(m1=-Exponent[p,T1,Min]))(T2^(m2=-Exponent[p,T2,Min]))p,{T1,T2}];
maxc=Max@Abs[Last/@crs];
minc=Min@Select[Abs[Last/@crs],#>0&];
If[minc==maxc,
s[_]=0,
s[c_]:=s[c]=N[Interpolation[{{Log@minc,1},{Log@maxc,0}}, InterpolationOrder->1][Log@c]]
];
Graphics[crs/.({x1_,x2_}->c_):>{
If[c==0,White,Lighter[If[c>0,Red,Blue], 0.88s[Abs@c]]],
Switch[shape,
Disk,Disk[(({{1, -1/2}, {0, (Sqrt[3])/2}})).{x1+m1,x2+m2},0.5],
Hexagon,Polygon[((({{1, -1/2}, {0, (Sqrt[3])/2}})).{x1+m1,x2+m2}+#)&/@hex]
]
}]
]

Sporadic Testing

K=Knot[3,1];Timing[Expand[θ[K]]]
TestSymmetries[K]

K=Knot[8,19];Timing[Expand[θ[K]]]
TestSymmetries[K]

Timing[Expand@(Subscript[θ, (Subscript[T, 1]),(Subscript[T, 2])])[Knot[3,1]]]

K=Knot[4,1]; Timing[θ[K]]
TestSymmetries[K]

K=Knot["K11n34"]; Timing[θ[K]]
TestSymmetries[K]

K=Knot["K11n42"]; Timing[θ[K]]
TestSymmetries[K]

PD[GST48]=PD[X[1,15,2,14],X[29,2,30,3],X[40,4,41,3],X[4,44,5,43],X[5,26,6,27],X[95,7,96,6],X[7,1,8,96],X[8,14,9,13],X[28,9,29,10],X[41,11,42,10],X[11,43,12,42],X[12,27,13,28],X[15,31,16,30],X[61,16,62,17],X[72,17,73,18],X[83,18,84,19],X[34,20,35,19],X[20,89,21,90],X[92,21,93,22],X[22,79,23,80],X[23,68,24,69],X[24,57,25,58],X[56,25,57,26],X[31,63,32,62],X[32,74,33,73],X[33,85,34,84],X[35,50,36,51],X[81,37,82,36],X[70,38,71,37],X[59,39,60,38],X[54,39,55,40],X[55,45,56,44],X[45,59,46,58],X[46,70,47,69],X[47,81,48,80],X[91,49,92,48],X[49,91,50,90],X[82,52,83,51],X[71,53,72,52],X[60,54,61,53],X[74,63,75,64],X[85,64,86,65],X[65,76,66,77],X[66,87,67,88],X[94,67,95,68],X[86,75,87,76],X[77,88,78,89],X[93,78,94,79]];

K=GST48; AbsoluteTiming[Short@θ[K]]
TestSymmetries[K]

(Subscript[PolyPlot, (Subscript[T, 1]),(Subscript[T, 2])])[-θ[GST48][[2]]]

(Subscript[PolyPlot, (Subscript[T, 1]),(Subscript[T, 2])])[-θ[GST48][[2]]/.{(Subscript[T, 1])->(Subscript[T, 1]),(Subscript[T, 2])->-(Subscript[T, 2])}]

(Subscript[PolyPlot, (Subscript[T, 1]),(Subscript[T, 2])])[θ[GST48][[2]]((Subscript[T, 1])+(Subscript[T, 2])-(Subscript[T, 3])-(Subscript[T, 1]^(-1))-(Subscript[T, 2]^(-1))+(Subscript[T, 3]^(-1)))]

AbsoluteTiming[(Subscript[θ, (Subscript[T, 1]),(Subscript[T, 2])])[GST48];]

AbsoluteTiming[(Subscript[θ, 22/7,34/21])[GST48]]

Systematic Testing

DuplicateFreeQ[θ/@AllKnots[{3,10}]]

Total[TestSymmetries/@AllKnots[{3,10}]]

DuplicateFreeQ[θ/@AllKnots[{3,12}]]

tab11=Table[K->θ@K,{K,AllKnots[{3,11}] }]

Gather[tab11,Last[#1]===Last[#2]&]

Select[Gather[tab11,Last[#1]===Last[#2]&], Length[#]>1&]

tab12=Table[K->θ@K,{K,AllKnots[{3,12}] }]

dup12=Map[First,Select[Gather[tab12,Last[#1]===Last[#2]&], Length[#]>1&],{2}]

Length/@dup12

Total[(Length/@dup12)-1]

Length/@Select[Gather[tab12/.{(Subscript[T, 1])->22/7, (Subscript[T, 2])->13/21},Last[#1]===Last[#2]&], Length[#]>1&]

Put[tab12/.{(Subscript[T, 1])->T1,(Subscript[T, 2])->T2}, "Data12.m"]

Ribbon Knots

Table[K->θ[K], {K,{Knot[6,1],Knot[8,8],Knot[8,9],Knot[8,20],Knot[9,27],Knot[9,41],Knot[9,46],Knot[10,3],Knot[10,22],Knot[10,35],Knot[10,42],Knot[10,48],Knot[10,75],Knot[10,87],Knot[10,99],Knot[10,123],Knot[10,129],Knot[10,137],Knot[10,140],Knot[10,153],Knot[10,155]}}]

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

DrawMorseLink[DK[250]]

Crossings[DK[576]]

AbsoluteTiming[θ[DK[3]]]

AbsoluteTiming[θ[DK[30]];]

AbsoluteTiming[θ[DK[60]];]

AbsoluteTiming[θ[DK[90]];]

AbsoluteTiming[θ120=θ[DK[120]];]

Put[θ120, "Theta4DK120.m"]

AbsoluteTiming[θ[DK[150]];]

(during the previous computation I biked home, so the AbsoluteTiming is too much)

AbsoluteTiming[θ[DK[180]];]

AbsoluteTiming[θ[DK[210]];]

AbsoluteTiming[θ[DK[240]];]

AbsoluteTiming[θ[DK[270]];]

Mathematica crashed while trying the above computation.

AbsoluteTiming[θ[DK[300]];]

Do[Echo/@AbsoluteTiming[n->(Subscript[θ, 22/7,34/21])[DK[n]]], {n,100,500,100}]

The following crashes at n=700:

Do[Echo/@AbsoluteTiming[n->(Subscript[θ, 22/7,34/21])[DK[n]]], {n,500,1000,100}]

Knot Genus

Import["KnotGenusFromKnotInfo.csv"][[2;;]]/.{K_String,pd_String,g_Integer}:>(Genus[Knot[K]]=g);

ρ[K_]:=ρ[K]=Module[{R,Cs,φ,n,A,s,i,j,k,Δ,G,ρ1},
R[s_,i_,j_]:=s((Subscript[g, j,i])((Subscript[g, (SuperPlus[j]),j])+(Subscript[g, j,(SuperPlus[j])])-(Subscript[g, i,j]))-(Subscript[g, i,i])((Subscript[g, j,(SuperPlus[j])])-1)-1/2);
{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];
ρ1=(∑_(k=1)^n)R@@Cs[[k]] - (∑_(k=1)^(2n))φ[[k]]((Subscript[g, k,k])-1/2);
Factor@{Δ,(Δ^2)ρ1/.(SuperPlus[α_]):>α+1/.(Subscript[g, α_,β_]):>G[[α,β]]}];

Table[{K, Genus[K], Exponent[θ[K][[1]],T],Exponent[ρ[K][[2]],T]/2,Exponent[θ[K][[2]],(Subscript[T, 1])]/2 ,Exponent[θ[K][[2]]/.{(Subscript[T, 1])->T,(Subscript[T, 2])->(T^2)},T]/6}, {K,AllKnots[{3,8}]}]//MatrixForm

Select[AllKnots[{3,12}], Genus[#]<Exponent[θ[#][[1]],T]&]

Select[AllKnots[{3,11}], Genus[#]>Exponent[θ[#][[1]],T]&]

Select[AllKnots[{3,12}], Genus[#]<Ceiling[Exponent[θ[#][[2]],(Subscript[T, 1])]/2]&]

Select[AllKnots[{3,10}], Genus[#]>Ceiling[Exponent[θ[#][[2]],(Subscript[T, 1])]/2]&]

Select[AllKnots[{3,12}],Genus[#]<Ceiling[Exponent[ρ[#][[2]],T]/2]&]

Select[AllKnots[{3,10}], 2Genus[#]>Exponent[ρ[#][[2]],T]&]

Select[AllKnots[{3,10}], Exponent[ρ[#][[2]],T]>Exponent[θ[#][[2]],(Subscript[T, 1])]&]

Select[AllKnots[{3,10}], Exponent[ρ[#][[2]],T]<Exponent[θ[#][[2]],(Subscript[T, 1])]&]

Factor@Alexander[Knot[10,107]][T]

Select[AllKnots[{3,12}], Genus[#]<Exponent[θ[#][[2]]/.{(Subscript[T, 1])->T,(Subscript[T, 2])->(T^2)},T]/6&]

Select[AllKnots[{3,10}], Genus[#]>Exponent[θ[#][[2]]/.{(Subscript[T, 1])->T,(Subscript[T, 2])->(T^2)},T]/6&]

sel=Select[AllKnots[{3,12}], Exponent[ρ[#][[2]],T]/2>Exponent[θ[#][[2]],(Subscript[T, 1])]/2&]

Select[AllKnots[{3,11}], Ceiling[Exponent[ρ[#][[2]],T]/2]<Exponent[θ[#][[2]],(Subscript[T, 1])]/2&]

Table[{K, Genus[K], Exponent[θ[K][[1]],T],Exponent[ρ[K][[2]],T]/2,Exponent[θ[K][[2]],(Subscript[T, 1])]/2 ,Exponent[θ[K][[2]]/.{(Subscript[T, 1])->T,(Subscript[T, 2])->(T^2)},T]/6}, {K,AllKnots[{3,7}]~Join~{Knot[9,24],Knot[9,30],Knot[10,107],Knot["K11n34"],Knot["K11n42"],GST48}}]//MatrixForm

Union@Table[Simplify[ρ[K][[2]]==(-θ[K][[2]]/.{(Subscript[T, 1])->T,(Subscript[T, 2])->1})], {K,AllKnots[{3,11}]}]

K=Knot[3,1];Factor@{(ρ[K][[2]]/.T->(T^3)),(-θ[K][[2]]/.{(Subscript[T, 1])->T,(Subscript[T, 2])->(T^2)})}

(Subscript[PolyPlot, (Subscript[T, 1]),(Subscript[T, 2])])[θ[Knot[10,107]][[2]]]