Pensieve header: Mathematica notebook accompanying Talks: LesDiablerets-2601.

Initialization

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\LesDiablerets-2601"];
Once[<< KnotTheory`]
SetOptions[$FrontEndSession,PrintingStyleEnvironment->"Working"];

PD[epd_EPD]:=PD@@epd/.{(Subscript[X, i_,j_]):>X[j,i+1,j+1,i],(Subscript[(OverBar[X]), i_,j_]):>X[j,i,j+1,i+1]}

Rot[{X_,φ_}]:={X,φ};
Rot[pd_PD]:=Module[{n,xs,x,rots,Xp,Xm,front={1},k},
n=Length@pd;rots=Table[0,{2n+1}];
xs=Cases[pd,x_X:>(Piecewise[{{Xp[x[[4]],x[[1]]], PositiveQ@x}, {Xm[x[[2]],x[[1]]], True}}])];
For[k=1,k<=2n,++k,
If[FreeQ[front,-k],
front=Flatten@Replace[front,k->(xs/.{
Xp[k,l_]|Xm[l_,k]:>{l+1,k+1,-l},
Xp[l_,k]|Xm[k,l_]:>(++rots[[l]];{-l,k+1,l+1}),
_Xp|_Xm:>{}
}), {1}],
Cases[front,k|-k]/.{k,-k}:>--rots[[k]];
]
];
{xs/.{Xp[i_,j_]:>{+1,i,j}, Xm[i_,j_]:>{-1,i,j}},rots} ];
Rot[K_]:=Rot[PD[K]];

Options[PolyPlot1]={Labeled->False};PolyPlot1[Δ_,OptionsPattern[]]:=Module[{Δ1,crs,m,maxc,minc,s,rect},
Δ1=PowerExpand@Expand@Δ;
rect={{0,0},{1,0},{1,1},{0,1}};
If[Δ1===0,Graphics[],
m=Max[-Exponent[Δ1,T,Min], Exponent[Δ1,T,Max]];
crs=CoefficientRules[(T^m)Δ1,{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, Shear->True};
PolyPlot2[θ_,OptionsPattern[]]:=Module[{θ1,crs,m1,m2,maxc,minc,s,stone,mat,p},
θ1=PowerExpand@Expand@θ;
If[θ1===0,Graphics[{White,Disk[]}],
If[OptionValue[Shear],
stone=Table[{Cos[α],Sin[α]}/Cos[2π/12]/2, {α,2π/12,2π,2π/6}];
mat=(({{1, -1/2}, {0, (Sqrt[3])/2}})),
stone={{1,1}, {-1,1},{-1,-1},{1,-1}}/2;
mat=IdentityMatrix[2];
];
m1=Max[-Exponent[θ1,(Subscript[T, 1]),Min], Exponent[θ1,(Subscript[T, 1]),Max]];
m2=Max[-Exponent[θ1,(Subscript[T, 2]),Min], Exponent[θ1,(Subscript[T, 2]),Max]];
crs=CoefficientRules[(Subscript[T, 1]^m1)(Subscript[T, 2]^m2)θ1,{(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=mat.{x1-m1,x2-m2};
Tooltip[Polygon[(p+#)&/@stone],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]
]];
Options[PolyPlot]={Labeled->False, ImageSize->Automatic};
PolyPlot[{Δ_,θ_},opts___Rule]:=GraphicsColumn[
{PolyPlot1[Δ,FilterRules[Join[{opts},Options[PolyPlot]],Options[PolyPlot1]]],
PolyPlot2[θ,FilterRules[Join[{opts},Options[PolyPlot]],Options[PolyPlot2]]]},
Spacings -> Scaled@0.08,ImagePadding->None,PlotRangePadding->None,
FilterRules[Join[{opts},Options[PolyPlot]],Options[GraphicsColumn]]
];

PPDemo

PPDemoRect=PolyPlot[{2(T^(-1))-1+3T,2+(Subscript[T, 1])-(Subscript[T, 1])(Subscript[T, 2])+(Subscript[T, 2])-(Subscript[T, 1]^(-1))+(Subscript[T, 1]^(-1))(Subscript[T, 2]^(-1))-(Subscript[T, 2]^(-1))},Labeled->True,Shear->False]

Export["figs/PPDemoRect.pdf",PPDemoRect]

PPDemoHex=PolyPlot[{2(T^(-1))-1+3T,2+(Subscript[T, 1])-(Subscript[T, 1])(Subscript[T, 2])+(Subscript[T, 2])-(Subscript[T, 1]^(-1))+(Subscript[T, 1]^(-1))(Subscript[T, 2]^(-1))-(Subscript[T, 2]^(-1))},Labeled->True]

Export["figs/PPDemoHex.pdf",PPDemoHex]

Beehive

Top18Data=(Get["C:\\drorbn\\AcademicPensieve\\Projects\\HigherRank\\DunfieldKnots\\D"<>ToString[#]<>".m"][[2,2]]/.{T1->(Subscript[T, 1]),T2->(Subscript[T, 2])})&/@{297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,317};

Top18Images=PolyPlot2/@Top18Data;

Show[Top18=Graphics[{
{0,0,1},{1,0,2},{2,0,3},
{0,1,4},{1,1,5},
{-1,2,6},{0,2,7},{1,2,8},
{-1,3,9},{0,3,10},
{-2,4,11},{-1,4,12},{0,4,13},
{-2,5,14},{-1,5,15},
{-3,6,16},{-2,6,17},{-1,6,18}
},
PlotRange->{{-0.6,6.1},{-0.5,2.5}}, ImageSize->1200]/.{x_,y_,k_}:>
Inset[
SetAlphaChannel[Top18Images[[k]],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
], ImageSize->Small]

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

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

Images51to68=PolyPlot2/@Data51to68;

Show[Beehive=Graphics[{
{0,0,1},{1,0,2},{2,0,3},
{0,1,4},{1,1,5},
{-1,2,6},{0,2,7},{1,2,8},
{-1,3,9},{0,3,10},
{-2,4,11},{-1,4,12},{0,4,13},
{-2,5,14},{-1,5,15},
{-3,6,16},{-2,6,17},{-1,6,18}
},
PlotRange->{{-0.6,6.1},{0,2}}, ImageSize->1200]/.{x_,y_,k_}:>
Inset[
SetAlphaChannel[Images51to68[[k]],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
], ImageSize->Small]

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

Θ Program

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

(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[g, 2,i,j])+((Subscript[T, 2]^s)-2)(Subscript[g, 2,j,j])-((Subscript[T, 1]^s)-1)((Subscript[T, 2]^s)+1) (Subscript[g, 1,j,i])))/((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;

Θ[K_]:=Θ[K]=Module[{X,φ,n,A,Δ,G,ev,θ,k,k1,k2},
{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[Sum[(Subscript[F, 1])[X[[k]]], {k,n}]];
θ+=ev[Sum[(Subscript[F, 2])[X[[k1]],X[[k2]]], {k1,n}, {k2,n}]];
θ+=ev[Sum[(Subscript[F, 3])[φ[[k]],k], {k,Length@φ}]];
Factor@{Δ,(Δ/.T->(Subscript[T, 1]))(Δ/.T->(Subscript[T, 2]))(Δ/.T->(Subscript[T, 3]))θ}
];

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

Export[
"figs/Program.pdf",
Append[
First@Cases[NotebookGet@EvaluationNotebook[], Cell[__,CellTags->"Program",___],∞],
PageWidth->600
]
]

Export["figs/ThetaConway.pdf",Echo@PolyPlot2[Θ[Knot@"K11n34"][[2]]]]

Export["figs/ThetaKT.pdf",Echo@PolyPlot2[Θ[Knot@"K11n42"][[2]]]]

The Rolfsen Table

tab250=Join[
{{1,0}},
Table[Θ[K], {K,AllKnots[{3,10}]}]
];

g250=GraphicsGrid[
Partition[PadRight[PolyPlot/@tab250, 256, Graphics[]],16],
Spacings -> 0,Dividers->All,ImagePadding->None,PlotRangePadding->None
]

Export["figs/Theta4Rolfsen.pdf",g250]

Pretzel Knots

(*L should be a list of an odd number of odd integers.*)
OddPretzel[L_]:=Module[{s=Total[Abs/@L],x},
PD@@Flatten@Table[x = Sum[Abs[L[[j]]],{j,1,u-1}];

If[EvenQ[u],
If[L[[u]]>0,
Join[Table[X[s+x+Abs[L[[u]]]-2k,x+2+2k,s+x+Abs[L[[u]]]-2k-1,x+1+2k],{k,0,((Abs[L[[u]]]-1)/2)}],
Table[X[x+2k,s+x+Abs[L[[u]]]+2-2k,x+1+2k,s+x+Abs[L[[u]]]+1-2k],{k,1,((Abs[L[[u]]]-1)/2)}]],
Join[Table[X[x+1+2k,s+x+Abs[L[[u]]]-2k,x+2+2k,s+x+Abs[L[[u]]]+1-2k],{k,0,((Abs[L[[u]]]-1)/2)}],
Table[X[s+x+Abs[L[[u]]]+1-2k,x+2k,s+x+Abs[L[[u]]]+2-2k,x+1+2k],{k,1,((Abs[L[[u]]]-1)/2)}]]]
,
If[L[[u]]>0,
Join[Table[X[x+1+2k,s+x+Abs[L[[u]]]+1-2k,x+2+2k,s+x+Abs[L[[u]]]-2k],{k,0,((Abs[L[[u]]]-1)/2)}],
Table[X[s+x+Abs[L[[u]]]+1-2k,x+1+2k,s+x+Abs[L[[u]]]+2-2k,x+2k],{k,1,((Abs[L[[u]]]-1)/2)}]],
Join[Table[X[s+x+Abs[L[[u]]]-2k,x+1+2k,s+x+Abs[L[[u]]]+1-2k,x+2+2k],{k,0,((Abs[L[[u]]]-1)/2)}],
Table[X[x+2k,s+x+Abs[L[[u]]]+1-2k,x+1+2k,s+x+Abs[L[[u]]]+2-2k],{k,1,((Abs[L[[u]]]-1)/2)}]]]
]
,{u,Length[L]}]
]

(*L should be a list L={L0,L1,..,Ln} where L0 and n>=0 are even and the Li, i>0 are odd integers.*)
EOddPretzel[LL_]:=Module[{L=Rest@LL,s,x,y,n},
s=2Abs[LL[[1]]]+Total[Abs/@L];n=Length[L];
PD@@Flatten@
Join[
If[LL[[1]]>0,
Join[Table[X[1+2k,s+1-2k,2+2k,s-2k],{k,0,((Abs[LL[[1]]])/2)-1}],Table[X[s+1-2k,1+2k,s+2-2k,2k],{k,1,((Abs[LL[[1]]])/2)}]],
Join[Table[X[s-2k,1+2k,s+1-2k,2+2k],{k,0,((Abs[LL[[1]]])/2)-1}],Table[X[2k,s+1-2k,1+2k,s+2-2k],{k,1,((Abs[LL[[1]]])/2)}]]
],
Table[x = Sum[Abs[L[[j]]],{j,u+1,n}];y= Abs[LL[[1]]]+Sum[Abs[L[[j]]],{j,1,u-1}];

If[EvenQ[u],
If[L[[u]]>0,
Join[Table[X[s+x+1+2k,y+1+2k,s+x+2+2k,y+2+2k],{k,0,((Abs[L[[u]]]-1)/2)}],
Table[X[y+2k,s+x+2k,y+1+2k,s+x+1+2k],{k,1,((Abs[L[[u]]]-1)/2)}]],
Join[Table[X[y+1+2k,s+x+2+2k,y+2+2k,s+x+1+2k],{k,0,((Abs[L[[u]]]-1)/2)}],
Table[X[s+x+2k,y+1+2k,s+x+1+2k,y+2k],{k,1,((Abs[L[[u]]]-1)/2)}]]]
,
If[L[[u]]>0,
Join[Table[X[y+1+2k,s+x+1+2k,y+2+2k,s+x+2+2k],{k,0,((Abs[L[[u]]]-1)/2)}],
Table[X[s+x+2k,y+2k,s+x+1+2k,y+1+2k],{k,1,((Abs[L[[u]]]-1)/2)}]],
Join[Table[X[s+x+1+2k,y+2+2k,s+x+2+2k,y+1+2k],{k,0,((Abs[L[[u]]]-1)/2)}],
Table[X[y+2k,s+x+1+2k,y+1+2k,s+x+2k],{k,1,((Abs[L[[u]]]-1)/2)}]]]
]
,{u,Length[L]}]
]
]

Crossings@EOddPretzel[{2,41,-41}]

P41=PolyPlot2[Θ[EOddPretzel[{2,41,-41}]][[2]]]

Export["figs/P41.pdf",P41]