(* ::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\\HigherRank"];
Once[<<KnotTheory`];
<<Rot.m


(* ::Input::Initialization:: *)
CCF[\[ScriptCapitalE]_] := ExpandDenominator@ExpandNumerator@Together[\[ScriptCapitalE]];
CCF[\[ScriptCapitalE]_] := Factor[\[ScriptCapitalE]];
CF[\[ScriptCapitalE]_List]:=CF/@\[ScriptCapitalE];
CF[\[ScriptCapitalE]_] := Module[{vs=Cases[\[ScriptCapitalE],Subscript[(x|p|\[Pi]|g), __],\[Infinity]]\[Union]{x,p,\[Epsilon]},ps,c},
Total[CoefficientRules[Expand[\[ScriptCapitalE]], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))] ];


(* ::Input::Initialization:: *)
Subscript[R, 1][s_,i_,j_]:=CF[
s(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\ 
\*SubscriptBox[\(g\), \(1, i, i\)]\ 
\*SubscriptBox[\(g\), \(2, j, i\)]\)+((-1+\!\(\*SubsuperscriptBox[\(T\), \(1\), \(s\)]\)) \!\(\*SubsuperscriptBox[\(T\), \(2\), \(2\ s\)]\) Subscript[g, 1,j,i] Subscript[g, 2,j,i])/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\))-Subscript[g, 1,i,i] Subscript[g, 2,j,j]-((-1+\!\(\*SubsuperscriptBox[\(T\), \(1\), \(s\)]\)) \!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\) Subscript[g, 1,j,i] Subscript[g, 2,j,j])/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\))-Subscript[g, 3,i,i]-(-1+\!\(\*SubsuperscriptBox[\(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+\!\(\*SubsuperscriptBox[\(T\), \(3\), \(s\)]\) ) Subscript[g, 3,j,i])/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\))-(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\ \((\(-1\) + 
\*SubsuperscriptBox[\(T\), \(3\), \(s\)]\ )\)\ 
\*SubscriptBox[\(g\), \(1, i, i\)]\ 
\*SubscriptBox[\(g\), \(3, j, i\)]\))/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\))-((-1+\!\(\*SubsuperscriptBox[\(T\), \(1\), \(s\)]\)) (1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\)) (-1+\!\(\*SubsuperscriptBox[\(T\), \(3\), \(s\)]\) ) Subscript[g, 1,j,i] Subscript[g, 3,j,i])/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\))+((-1+\!\(\*SubsuperscriptBox[\(T\), \(3\), \(s\)]\) ) Subscript[g, 2,i,j] Subscript[g, 3,j,i])/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\))-(1-\!\(\*SubsuperscriptBox[\(T\), \(3\), \(s\)]\) ) Subscript[g, 2,j,i] Subscript[g, 3,j,i]+((-2+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\)) (-1+\!\(\*SubsuperscriptBox[\(T\), \(3\), \(s\)]\) ) Subscript[g, 2,j,j] Subscript[g, 3,j,i])/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\))+Subscript[g, 1,i,i] Subscript[g, 3,j,j]+((-1+\!\(\*SubsuperscriptBox[\(T\), \(1\), \(s\)]\)) \!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\) Subscript[g, 1,j,i] Subscript[g, 3,j,j])/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\))-Subscript[g, 2,i,i] Subscript[g, 3,j,j]-\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)]\ 
\*SubscriptBox[\(g\), \(2, j, i\)]\ 
\*SubscriptBox[\(g\), \(3, j, j\)]\)+1/2)];
Subscript[\[CapitalGamma], 1][\[CurlyPhi]_,k_]:=CF[-(\[CurlyPhi]/2)+\[CurlyPhi] Subscript[g, 3,k,k]];
\[Theta][{s1_,i1_,j1_},{s2_,i2_,j2_}]:=CF[
1/(-1+\!\(\*SubsuperscriptBox[\(T\), \(2\), \(s2\)]\)) s2 (-1+(Subscript[T, 1] Subscript[T, 2])^s2) ((-1+\!\(\*SubsuperscriptBox[\(T\), \(1\), \(s1\)]\)) Subscript[g, 1,j2,i1] (\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s1\)]\ 
\*SubscriptBox[\(g\), \(2, i2, i1\)]\)-Subscript[g, 2,i2,j1]) Subscript[g, 3,j1,i2]-(-1+\!\(\*SubsuperscriptBox[\(T\), \(1\), \(s1\)]\)) Subscript[g, 1,j2,i1] (\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s1\)]\ 
\*SubscriptBox[\(g\), \(2, j2, i1\)]\)-Subscript[g, 2,j2,j1]) Subscript[g, 3,j1,i2])]


(* ::Input::Initialization:: *)
Subscript[T, 3]=Subscript[T, 1] Subscript[T, 2];
\[Theta][K_]:=\[Theta][K]=Module[{Cs,\[CurlyPhi],n,A,s,i,j,k,\[CapitalDelta],G,\[Nu],\[Alpha],\[Beta],gEval,Y,c,z},
{Cs,\[CurlyPhi]}=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}
}))];
\[CapitalDelta]=T^((-Total[\[CurlyPhi]]-Total[Cs[[All,1]]])/2) Det[A];
PrintTemporary["Done A"];
G=Inverse[A];
PrintTemporary["Done G"];
gEval[\[ScriptCapitalE]_]:=CCF[\[ScriptCapitalE]/.Subscript[g, \[Nu]_,\[Alpha]_,\[Beta]_]:>(G[[\[Alpha],\[Beta]]]/.T->Subscript[T, \[Nu]])];
z=gEval[\!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k1 = 1\), \(n\)]\(
\*SubsuperscriptBox[\(\[Sum]\), \(k2 = 1\), \(n\)]\[Theta][Cs[\([k1]\)], Cs[\([k2]\)]]\)\)];
PrintTemporary["Done \[Theta]"];
z+=gEval[\!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(n\)]\(
\*SubscriptBox[\(R\), \(1\)] @@ Cs[[k]]\)\)];
PrintTemporary["Done \!\(\*SubscriptBox[\(R\), \(1\)]\)"];
z+=gEval[\!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(2  n\)]\(
\(\*SubscriptBox[\(\[CapitalGamma]\), \(1\)]\)[\[CurlyPhi][\([k]\)], k]\)\)];
{\[CapitalDelta],(\[CapitalDelta]/.T->Subscript[T, 1])(\[CapitalDelta]/.T->Subscript[T, 2])(\[CapitalDelta]/.T->Subscript[T, 3])z}//CCF
];


(* ::Input::Initialization:: *)
Subscript[\[Theta], T1_,T2_][K_]:=Subscript[\[Theta], T1,T2][K]=Module[{Cs,\[CurlyPhi],n,A,s,i,j,k,\[CapitalDelta],G,gEval,Y,yEval,c,z=0},
{Cs,\[CurlyPhi]}=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}
}))];
\[CapitalDelta][0]:=\[CapitalDelta][0]=T^((-Total[\[CurlyPhi]]-Total[Cs[[All,1]]])/2) Det[A];
G[0]:=G[0]=Inverse[A];
{\[CapitalDelta][1],G[1]}=If[NumberQ@T1,
{Det[A/.T->T1],Inverse[A/.T->T1]},{\[CapitalDelta][0],G[0]}/.T->T1 ];
temp=PrintTemporary@"Done with {\[CapitalDelta][1],G[1]}.";
{\[CapitalDelta][2],G[2]}=If[NumberQ@T2,
{Det[A/.T->T2],Inverse[A/.T->T2]},{\[CapitalDelta][0],G[0]}/.T->T2 ];
NotebookDelete[temp]; temp=PrintTemporary@"Done with {\[CapitalDelta][2],G[2]}.";
{\[CapitalDelta][3],G[3]}=If[NumberQ[T1 T2],
{Det[A/.T->T1 T2],Inverse[A/.T->T1 T2]},{\[CapitalDelta][0],G[0]}/.T->T1 T2 ];
NotebookDelete[temp]; temp=PrintTemporary@"Done with {\[CapitalDelta][3],G[3]}.";
gEval[\[ScriptCapitalE]_]:=CCF[\[ScriptCapitalE]//.{Subscript[T, 1]->T1,Subscript[T, 2]->T2,Subscript[g, \[Nu]_,\[Alpha]_,\[Beta]_]:>G[\[Nu]][[\[Alpha],\[Beta]]]}];
Do[z+=gEval[\[Theta][Cs[[k1]],Cs[[k2]]]],{k1,n},{k2,n}];
Do[z+=gEval[Subscript[R, 1]@@Cs[[k]]],{k,n}];
Do[z+=gEval[Subscript[\[CapitalGamma], 1][\[CurlyPhi][[k]],k]],{k,2n}];
NotebookDelete[temp0];NotebookDelete[temp];
{{\[CapitalDelta][1],\[CapitalDelta][2],\[CapitalDelta][3]},\[CapitalDelta][1]\[CapitalDelta][2]\[CapitalDelta][3]z}//CCF
];


(* ::Input::Initialization:: *)
TestSymmetries[K_]:=Module[{\[Theta]0,\[Theta]1},
{\[Theta]0,\[Theta]1}={\[Theta][K][[2]],\[Theta][Mirror@K][[2]]};
Simplify@And[
\[Theta]0==(\[Theta]0/.{Subscript[T, 1]->Subscript[T, 2],Subscript[T, 2]->Subscript[T, 1]}),
\[Theta]0==-\[Theta]1,
\[Theta]0==(\[Theta]0/.Subscript[T, i_]:>\!\(\*SubsuperscriptBox[\(T\), \(i\), \(-1\)]\)),
\[Theta]0==(\[Theta]0/.Subscript[T, 2]->\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(-1\)] 
\*SubsuperscriptBox[\(T\), \(2\), \(-1\)]\))
]
]


(* ::Input::Initialization:: *)
hex=Table[{Cos[\[Alpha]],Sin[\[Alpha]]}/Cos[2\[Pi]/12]/2, {\[Alpha],2\[Pi]/12,2\[Pi],2\[Pi]/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]
]
}]
]


(* ::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:: *)
\[Rho][K_]:=\[Rho][K]=Module[{R,Cs,\[CurlyPhi],n,A,s,i,j,k,\[CapitalDelta],G,\[Rho]1},
R[s_,i_,j_]:=s(Subscript[g, j\[InvisibleComma]i](Subscript[g, SuperPlus[j],j]+Subscript[g, j,SuperPlus[j]]-Subscript[g, i\[InvisibleComma]j])-Subscript[g, i\[InvisibleComma]i](Subscript[g, j,SuperPlus[j]]-1)-1/2);
{Cs,\[CurlyPhi]}=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}
}))];
\[CapitalDelta]=T^((-Total[\[CurlyPhi]]-Total[Cs[[All,1]]])/2) Det[A];
G=Inverse[A];
\[Rho]1=\!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(n\)]\(R @@ Cs[[k]]\)\) - \!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(2  n\)]\(\[CurlyPhi][[k]] \((
\*SubscriptBox[\(g\), \(k\[InvisibleComma]k\)] - 1/2)\)\)\);
Factor@{\[CapitalDelta],\[CapitalDelta]^2 \[Rho]1/.SuperPlus[\[Alpha]_]:>\[Alpha]+1/.Subscript[g, \[Alpha]_,\[Beta]_]:>G[[\[Alpha],\[Beta]]]}];



