(* ::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, 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[\[Gamma], 1][\[CurlyPhi]_,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-\!\(
\*SubsuperscriptBox[\(T\), \(3\), \(-1\)] 
\*SubscriptBox[\(x\), \(3, i\)] \((
\*SubscriptBox[\(p\), \(3, i + 1\)] - 
\*SubscriptBox[\(p\), \(3, j + 1\)])\)\)},
\[CurlyPhi]/2
}
]]


(* ::Input::Initialization:: *)
{SuperStar[p],SuperStar[x],SuperStar[\[Pi]],SuperStar[\[Xi]]}={\[Pi],\[Xi],p,x};  SuperStar[(Subscript[u_, i__])]:=Subscript[(SuperStar[u]), i];


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Zip\), \({}\)]\)[\[ScriptCapitalE]_]:=\[ScriptCapitalE];
\!\(\*SubscriptBox[\(Zip\), \({\[Zeta]_, \[Zeta]s___}\)]\)[\[ScriptCapitalE]_] := (Collect[\[ScriptCapitalE]//\!\(\*SubscriptBox[\(Zip\), \({\[Zeta]s}\)]\),\[Zeta]] /. f_. \[Zeta]^d_.:>(D[f,{SuperStar[\[Zeta]],d}]))/.SuperStar[\[Zeta]]->0


(* ::Input::Initialization:: *)
px2g[\[ScriptCapitalE]_]:=CF@Module[{ps,xs,Q,\[Alpha],\[Beta]},
ps=Union[Cases[\[ScriptCapitalE],Subscript[p, __],\[Infinity]]]; xs=Union[Cases[\[ScriptCapitalE],Subscript[x, __],\[Infinity]]];
Q=Sum[SuperStar[p0] SuperStar[x0] Subscript[g, p0[[2]],x0[[2]],p0[[3]],x0[[3]]],{p0,ps},{x0,xs}];
Expand[Subscript[Zip, ps\[Union]xs][\[ScriptCapitalE] E^Q]/.Subscript[g, \[Alpha]_,\[Beta]_,i_,j_]:>If[\[Alpha]===\[Beta],Subscript[g, \[Alpha],i,j],0]]
]


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


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


(* ::Input::Initialization:: *)
\[Theta][{1,i0_,j0_},{1,i1_,j1_}]=px2g[Subscript[r, 0,pxx][1,i0,j0]Subscript[r, 1,ppx][1,i1,j1]]
\[Theta][{1,i0_,j0_},{-1,i1_,j1_}]=px2g[Subscript[r, 0,pxx][1,i0,j0]Subscript[r, 1,ppx][-1,i1,j1]]
\[Theta][{-1,i0_,j0_},{1,i1_,j1_}]=px2g[Subscript[r, 0,pxx][-1,i0,j0]Subscript[r, 1,ppx][1,i1,j1]]
\[Theta][{-1,i0_,j0_},{-1,i1_,j1_}]=px2g[Subscript[r, 0,pxx][-1,i0,j0]Subscript[r, 1,ppx][-1,i1,j1]]


(* ::Input::Initialization:: *)
Subscript[\[CapitalGamma], 1][\[CurlyPhi]_,k_]=px2g[Subscript[\[Gamma], 1][\[CurlyPhi],k]]


(* ::Input::Initialization:: *)
Subscript[T, 3]=Subscript[T, 1] Subscript[T, 2];
\[Theta][K_]:=Module[{Cs,\[CurlyPhi],n,A,s,i,j,k,\[CapitalDelta],G,\[Nu],\[Alpha],\[Beta],gEval,Y,yEval,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];
G=Inverse[A]; 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\)\(]\)]]\)\)];
z+=gEval[\!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(n\)]\(
\*SubscriptBox[\(R\), \(1\)] @@ Cs[[k]]\)\)];
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_]:=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:: *)
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]
}]
]


(* ::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]]



