(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



(* ::Input::Initialization:: *)
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\Theta"];


(* ::Input::Initialization:: *)
<< KnotTheory`


(* ::Input::Initialization:: *)
(* Rot suppressed *)


(* ::Input::Initialization:: *)
Rot[pd_PD]:=Module[{n,xs,x,rots,Xp,Xm,front={1},k},
n=Length@pd;rots=Table[0,{2n}];
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]];


(* ::Input::Initialization:: *)
(* PolyPlot suppressed *)


(* ::Input::Initialization:: *)
PolyPlot1[\[CapitalDelta]_]:=Module[{crs,m,maxc,minc,s,rect},
rect={{0,0},{1,0},{1,1},{0,1}};
If[Expand[\[CapitalDelta]]===0,Graphics[],
m=Max[-Exponent[\[CapitalDelta],T,Min], Exponent[\[CapitalDelta],T,Max]];
crs=CoefficientRules[T^m \[CapitalDelta],{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)]
},AspectRatio->Min[1/5 ,1/Sqrt[m+1]],ImagePadding->None,PlotRangePadding->None]
]];
Options[PolyPlot2]={Labeled->False};
PolyPlot2[\[Theta]_,OptionsPattern[]]:=Module[{crs,m1,m2,maxc,minc,s,hex,p},
If[Expand[\[Theta]]===0,Graphics[{White,Disk[]}],
hex=Table[{Cos[\[Alpha]],Sin[\[Alpha]]}/Cos[2\[Pi]/12]/2, {\[Alpha],2\[Pi]/12,2\[Pi],2\[Pi]/6}];
m1=Max[-Exponent[\[Theta],Subscript[T, 1],Min], Exponent[\[Theta],Subscript[T, 1],Max]];
m2=Max[-Exponent[\[Theta],Subscript[T, 2],Min], Exponent[\[Theta],Subscript[T, 2],Max]];
crs=CoefficientRules[\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(m1\)] 
\*SubsuperscriptBox[\(T\), \(2\), \(m2\)] \[Theta]\),{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\[Pi]/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=({
 {1, -1/2},
 {0, Sqrt[3]/2}
}) . {x1-m1,x2-m2};
Tooltip[Polygon[(p+#)&/@hex],c \!\(\*SubsuperscriptBox[\(T\), \(1\), \(x1 - m1\)]\) \!\(\*SubsuperscriptBox[\(T\), \(2\), \(x2 - m2\)]\)] ,
If[Not@OptionValue[Labeled],{},{Black, Text[Style[c \!\(\*SubsuperscriptBox[\(T\), \(1\), \(x1 - m1\)]\) \!\(\*SubsuperscriptBox[\(T\), \(2\), \(x2 - m2\)]\),30],p]}]
}
},ImagePadding->None,PlotRangePadding->None]
]];
PolyPlot[{\[CapitalDelta]_,\[Theta]_},opts___Rule]:=GraphicsColumn[
{PolyPlot1[\[CapitalDelta]],PolyPlot2[\[Theta],FilterRules[{opts},Options[PolyPlot2]]]},
Spacings -> Scaled@0.08,ImagePadding->None,PlotRangePadding->None,
FilterRules[{opts},Options[GraphicsColumn]]
];


(* ::Input::Initialization:: *)
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]];


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


(* ::Input::Initialization:: *)
PolyPlot[{\[CapitalDelta]_,\[Theta]_},opts___Rule]:=Module[
{crs,m,m1,m2,maxc,minc,s,rect,hex},
GraphicsColumn[{
rect={{0,0},{1,0},{1,1},{0,1}};
hex=Table[{Cos[\[Alpha]],Sin[\[Alpha]]}/Cos[2\[Pi]/12]/2, {\[Alpha],2\[Pi]/12,2\[Pi],2\[Pi]/6}];
If[Expand[\[CapitalDelta]]===0,Graphics[],
m=Max[-Exponent[\[CapitalDelta],T,Min], Exponent[\[CapitalDelta],T,Max]];
crs=CoefficientRules[T^m \[CapitalDelta],{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)]
},AspectRatio->Min[1/5 ,1/Sqrt[m+1]],ImagePadding->None,PlotRangePadding->None]
],
If[Expand[\[Theta]]===0,Graphics[{White,Disk[]}],
m1=Max[-Exponent[\[Theta],Subscript[T, 1],Min], Exponent[\[Theta],Subscript[T, 1],Max]];
m2=Max[-Exponent[\[Theta],Subscript[T, 2],Min], Exponent[\[Theta],Subscript[T, 2],Max]];
crs=CoefficientRules[\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(m1\)] 
\*SubsuperscriptBox[\(T\), \(2\), \(m2\)] \[Theta]\),{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[{{White,Disk[{0,0},1+Cos[2\[Pi]/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]],
Tooltip[Polygon[(({
 {1, -1/2},
 {0, Sqrt[3]/2}
}) . {x1-m1,x2-m2}+#)&/@hex],c \!\(\*SubsuperscriptBox[\(T\), \(1\), \(x1 - m1\)]\) \!\(\*SubsuperscriptBox[\(T\), \(2\), \(x2 - m2\)]\)] 
}
},ImagePadding->None,PlotRangePadding->None]
]
},Spacings -> Scaled@0.08,ImagePadding->None,PlotRangePadding->None,opts]];



