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))] ];

Must get rid of the “+1”s below:

{
{(Subscript[r, 0,pxx])[1,i_,j_],(Subscript[r, 0,pxx])[-1,i_,j_]},
{(Subscript[r, 1,ppx])[1,i_,j_],(Subscript[r, 1,ppx])[-1,i_,j_]},
{(Subscript[r, 1,rest])[1,i_,j_],(Subscript[r, 1,rest])[-1,i_,j_]},
(Subscript[γ, 1])[φ_,k_]
}=CF[Plus[
{(Subscript[T, 1]),1-(Subscript[T, 1])(Subscript[T, 2]),(Subscript[T, 1])(1-(Subscript[T, 1])(Subscript[T, 2])),(Subscript[T, 1])(1-(Subscript[T, 1])(Subscript[T, 2]))}*Get["px-data.m"],
-{{0,0},
{0,0},
{1/2+(Subscript[T, 3])(Subscript[x, 3,i])((Subscript[p, 3,i+1])-(Subscript[p, 3,j+1])),-1/2-(Subscript[T, 3]^(-1))(Subscript[x, 3,i])((Subscript[p, 3,i+1])-(Subscript[p, 3,j+1]))},
φ/2
}
]]

(Subscript[r, 1,rest])[1,4,5]

{(SuperStar[p]),(SuperStar[x]),(SuperStar[π]),(SuperStar[ξ])}={π,ξ,p,x};  (SuperStar[((Subscript[u_, i__]))]):=(Subscript[((SuperStar[u])), i]);

(Subscript[Zip, {}])[ℰ_]:=ℰ;
(Subscript[Zip, {ζ_,ζs___}])[ℰ_] := (Collect[ℰ//(Subscript[Zip, {ζs}]),ζ] /. f_.(ζ^(d_.)):>(D[f,{(SuperStar[ζ]),d}]))/.(SuperStar[ζ])->0

px2g[ℰ_]:=CF@Module[{ps,xs,Q,α,β},
ps=Union[Cases[ℰ,(Subscript[p, __]),∞]]; xs=Union[Cases[ℰ,(Subscript[x, __]),∞]];
Q=Sum[(SuperStar[p0]) (SuperStar[x0]) (Subscript[g, p0[[2]],x0[[2]],p0[[3]],x0[[3]]]),{p0,ps},{x0,xs}];
Expand[(Subscript[Zip, ps⋃xs])[ℰ (E^Q)]/.(Subscript[g, α_,β_,i_,j_]):>If[α===β,(Subscript[g, α,i,j]),0]]
]

px2g[ (Subscript[p, 2,j]^2) (Subscript[x, 2,i]) (Subscript[x, 2,j])]

(Subscript[R, 1])[1,i_,j_]=px2g[(Subscript[r, 1,rest])[1,i,j]]

(Subscript[R, 1])[-1,i_,j_]=px2g[(Subscript[r, 1,rest])[-1,i,j]]

px2g[(Subscript[r, 0,pxx])[1,i0,j0](Subscript[r, 1,ppx])[1,i1,j1]]

θ[{1,i0_,j0_},{1,i1_,j1_}]=px2g[(Subscript[r, 0,pxx])[1,i0,j0](Subscript[r, 1,ppx])[1,i1,j1]]
θ[{1,i0_,j0_},{-1,i1_,j1_}]=px2g[(Subscript[r, 0,pxx])[1,i0,j0](Subscript[r, 1,ppx])[-1,i1,j1]]
θ[{-1,i0_,j0_},{1,i1_,j1_}]=px2g[(Subscript[r, 0,pxx])[-1,i0,j0](Subscript[r, 1,ppx])[1,i1,j1]]
θ[{-1,i0_,j0_},{-1,i1_,j1_}]=px2g[(Subscript[r, 0,pxx])[-1,i0,j0](Subscript[r, 1,ppx])[-1,i1,j1]]

CF[θ[{1,i0,j0},{1,i1,j1}]+(θ[{-1,i0,j0},{-1,i1,j1}]/.(Subscript[T, i_]):>(Subscript[T, i]^(-1)))]

CF[θ[{1,i0,j0},{-1,i1,j1}]+(θ[{-1,i0,j0},{1,i1,j1}]/.(Subscript[T, i_]):>(Subscript[T, i]^(-1)))]

(Subscript[Γ, 1])[φ_,k_]=px2g[(Subscript[γ, 1])[φ,k]]

The Programs

(Subscript[T, 3])=(Subscript[T, 1])(Subscript[T, 2]);
θ[K_]:=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,ν,α,β,gEval,Y,yEval,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[ℰ_]:=CCF[ℰ/.(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}//CCF
];

(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)))
]
]

(Subscript[PolyPlot, T1_,T2_])[p_]:=Module[{crs,m1,m2,mc},
crs=CoefficientRules[(T1^(m1=-Exponent[p,T1,Min]))(T2^(m2=-Exponent[p,T2,Min]))p,{T1,T2}];
mc=Max@Abs[Last/@crs];
Graphics[crs/.({x1_,x2_}->c_):>{
Which[
c==0,White,
c>0,Lighter[Red,1-c/mc],
 c<0, Lighter[Blue,1+c/mc]
],
Disk[(({{1, -1/2}, {0, (Sqrt[3])/2}})).{x1+m1,x2+m2},0.5]
}]
]

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]]]

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]]

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}]