(* ::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:: *)
Once[<<KnotTheory`]


(* ::Input::Initialization:: *)
NextHead[fr_]:=Min[Select[fr,(Abs[#]>1&&IntegerQ[#])&]]
FindNextCross[todo_,Nh_]:=First@Select[todo,If[PositiveQ[#],#[[1]]==Nh||#[[4]]==Nh,#[[1]]==Nh||#[[2]]==Nh]&]
Bend[X[a_,b_,c_,d_],h_]:=If[PositiveQ[X[a,b,c,d]],If[h==a,{I d,c,b},{c,b,-I a}],If[h==a,{d,c,-I b},{ I a,d,c}]]
CheckCap[fr_,rots_]:=Module[{i,newrots=rots, newfront=fr},
Do[If[Abs[fr[[i]]]===Abs[fr[[i+1]]],
If[IntegerQ[fr[[i]]],newrots[[Abs[fr[[i]]]]]=(-I+fr[[i+1]]/fr[[i]])/(2I),newrots[[Abs[fr[[i]]]]]=(I+fr[[i]]/fr[[i+1]])/(2I)];
newfront = Delete[newfront,{{i},{i+1}}];Break[];
],{i,Length[fr]-1}];
Return[{newfront,newrots}]
]
RotLink[pd_]:=Module[{safety=0,front={1},Nh=1,rots=ConstantArray[0,2Length[pd]+1]},
While[safety<1000&&!(front==={1}&&Nh!=1),
safety++;
If[Length[SequenceCases[Abs/@front,{a_,a_}]]>0,
{front,rots} = CheckCap[front,rots];,
front=Flatten[front/. Nh->Bend[FindNextCross[pd,Nh],Nh]]
];
Nh=NextHead[front];
];
Return[{Cases[List@@pd,X[a_,b_,c_,d_]->If[PositiveQ[X[a,b,c,d]],{1,d,a,b,c},{-1,b,a,d,c}]]/.{{s_,k_,l_,1,m_}:>{s,k,l,2Length[pd]+1,m},{s_,k_,l_,m_,1}:>{s,k,l,m,2Length[pd]+1}},rots}];
]


(* ::Input::Initialization:: *)
Subscript[R, 1][s_,i_,j_,ip_,jp_]:=s(Subscript[g, j\[InvisibleComma]i](Subscript[g, jp,j]+Subscript[g, j,jp]-Subscript[g, i\[InvisibleComma]j])-Subscript[g, i\[InvisibleComma]i](Subscript[g, j,jp]-1)-1/2);
\[Rho][Cs_,\[CurlyPhi]_]:=Module[{n,A,s,i,j,k,\[CapitalDelta],G,\[Rho]1},
 n=Length[Cs];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_,ip_,jp_}:>(A[[{i,j},{ip,jp}]]+=({
 {-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\)]\(
\*SubscriptBox[\(R\), \(1\)] @@ 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]]]}];



