(* ::Package:: *)

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

(* ::Input::Initialization:: *)
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\Theta"]
Once[<< KnotTheory`]


(* ::Input::Initialization:: *)
NextHead[fr_]:=Min[Select[fr,(Abs[#]>1&&IntegerQ[#])&]]
FindNextCross[todo_,Nh_]:=Module[{Cand=Select[todo,If[PositiveQ[#],#[[1]]==Nh||#[[4]]==Nh,#[[1]]==Nh||#[[2]]==Nh]&]},
If[Length[Cand]==0,False,First@Cand]
]
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}]
]
FindComponents[pd_]:=Module[{cl,L=Length[pd],comps}, (*could have used KnotTheory's Skeleton function*)
SetAttributes[S,Orderless];
(*two edges are equivalent iff they belong to the same component. We start by writing down a list of the equivalence classes.*)
cl=Sort[((S@@Flatten[List@@pd/.X[a_,b_,c_,d_]:>{S[a,c],S[b,d]}])//.{S[u___,S[a___,b_],S[b_,c___]]:>S[u,S[a,b,c]]})/.S->List];
comps=Append[Table[First@First@Position[cl,j],{j,1,2L}],1] (*put a 1 at the end because we opened up component 1.*)
]
RotLink[pd_PD]:=Module[{safety=0,front={1},heads={1},rots=ConstantArray[0,2Length[pd]+1],comps=FindComponents[pd],todo=pd,cr},
While[safety<20000&&!(front==={1}&&heads!={1}),
safety++;
If[Length[SequenceCases[Abs/@front,{a_,a_}]]>0,
{front,rots} = CheckCap[front,rots],
heads=Sort@Select[front,IntegerQ[#]&];
Do[cr=FindNextCross[todo,h];
If[Head@cr===X,todo=DeleteCases[todo,cr];(*Print["h,cr= ", h,cr];*)
front=Flatten[front/. h->Bend[cr,h]];Break[]],{h,heads}]
];
];
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,comps}];
]
RotLink[K_]:=RotLink[PD[K]];


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


(* ::Input::Initialization:: *)
Subscript[T, 3]=Subscript[T, 1] Subscript[T, 2];


(* ::Input::Initialization:: *)
Subscript[R, 1][s_,i_,j_,ip_,jp_]=CF[D1 D2 D3 (s(1/2-D3^-1 Subscript[g, 3\[InvisibleComma]i\[InvisibleComma]i]+\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SuperscriptBox[\(D1\), \(-1\)] 
\*SubscriptBox[\(g\), \(1\[InvisibleComma]i\[InvisibleComma]i\)] 
\*SuperscriptBox[\(D2\), \(-1\)] 
\*SubscriptBox[\(g\), \(2\[InvisibleComma]j\[InvisibleComma]i\)]\)-D1^-1 Subscript[g, 1\[InvisibleComma]i\[InvisibleComma]i] D2^-1 Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]j]-(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] - 1\))D2^-1 Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]i] D3^-1 Subscript[g, 3\[InvisibleComma]i\[InvisibleComma]i]+2D2^-1 Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]j] D3^-1 Subscript[g, 3\[InvisibleComma]i\[InvisibleComma]i]-(1-\!\(\*SubsuperscriptBox[\(T\), \(3\), \(s\)]\))D2^-1 Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]i] D3^-1 Subscript[g, 3\[InvisibleComma]j\[InvisibleComma]i]-D2^-1 Subscript[g, 2\[InvisibleComma]i\[InvisibleComma]i] D3^-1 Subscript[g, 3\[InvisibleComma]j\[InvisibleComma]j]-\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SuperscriptBox[\(D2\), \(-1\)] 
\*SubscriptBox[\(g\), \(2\[InvisibleComma]j\[InvisibleComma]i\)] 
\*SuperscriptBox[\(D3\), \(-1\)] 
\*SubscriptBox[\(g\), \(3\[InvisibleComma]j\[InvisibleComma]j\)]\)+D1^-1 Subscript[g, 1\[InvisibleComma]i\[InvisibleComma]i] D3^-1 Subscript[g, 3\[InvisibleComma]j\[InvisibleComma]j]+((\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(s\)] - 1\))D1^-1 Subscript[g, 1\[InvisibleComma]j\[InvisibleComma]i](\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(2  s\)] 
\*SuperscriptBox[\(D2\), \(-1\)] 
\*SubscriptBox[\(g\), \(2\[InvisibleComma]j\[InvisibleComma]i\)]\)-\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SuperscriptBox[\(D2\), \(-1\)] 
\*SubscriptBox[\(g\), \(2\[InvisibleComma]j\[InvisibleComma]j\)]\)+\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SuperscriptBox[\(D3\), \(-1\)] 
\*SubscriptBox[\(g\), \(3\[InvisibleComma]j\[InvisibleComma]j\)]\))+(\!\(
\*SubsuperscriptBox[\(T\), \(3\), \(s\)] - 1\))D3^-1 Subscript[g, 3\[InvisibleComma]j\[InvisibleComma]i](1-\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SuperscriptBox[\(D1\), \(-1\)] 
\*SubscriptBox[\(g\), \(1\[InvisibleComma]i\[InvisibleComma]i\)]\)-(\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(s\)] - 1\))(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] + 1\))D1^-1 Subscript[g, 1\[InvisibleComma]j\[InvisibleComma]i]+(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] - 2\))D2^-1 Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]j]+D2^-1 Subscript[g, 2\[InvisibleComma]i\[InvisibleComma]j]))/(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] - 1\))))]


(* ::Input::Initialization:: *)
\[Theta][{s0_,i0_,j0_,ip0_,jp0_},{s1_,i1_,j1_,ip1_,jp1_}]:=CF[D1 D2 D3 (s1(\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(s0\)] - 1\))(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s1\)] - 1\))^-1 (\!\(
\*SubsuperscriptBox[\(T\), \(3\), \(s1\)] - 1\))D1^-1 Subscript[g, 1,j1,i0] D3^-1 Subscript[g, 3,j0,i1]( (\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s0\)] 
\*SuperscriptBox[\(D2\), \(-1\)] 
\*SubscriptBox[\(g\), \(2, i1, i0\)]\)-D2^-1 Subscript[g, 2,i1,j0])- (\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s0\)] 
\*SuperscriptBox[\(D2\), \(-1\)] 
\*SubscriptBox[\(g\), \(2, j1, i0\)]\)-D2^-1 Subscript[g, 2,j1,j0])))]


(* ::Input::Initialization:: *)
Subscript[\[CapitalGamma], 1][\[CurlyPhi]_,k_]=-D1 D2 D3 \[CurlyPhi]/2+\[CurlyPhi] Subscript[g, 3\[InvisibleComma]k\[InvisibleComma]k]D1 D2 


(* ::Input::Initialization:: *)
adj[m_]:=Map[Reverse,Minors[Transpose[m],Length[m]-1],{0,1}]Table[(-1)^(i+j),{i,Length[m]},{j,Length[m]}]

\[Theta][K_]:=\[Theta][K]=Module[{Cs,\[CurlyPhi],n,A,s,i,j,k,jp,ip,\[CapitalDelta],\[CapitalDelta]1,\[CapitalDelta]2,\[CapitalDelta]3,G,\[Nu],\[Alpha],\[Beta],gEval,c,z,comp},
{Cs,\[CurlyPhi],comp}=RotLink[K]; 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}
}))];
(*Print[A//MatrixForm];*)
\[CapitalDelta]=T^((-Total[\[CurlyPhi]]-Total[Cs[[All,1]]])/2) Det[A];
\[CapitalDelta]1=(\[CapitalDelta]/.T->Subscript[T, 1]);\[CapitalDelta]2=(\[CapitalDelta]/.T->Subscript[T, 2]);\[CapitalDelta]3=(\[CapitalDelta]/.T->Subscript[T, 3]);
G=T^((-Total[\[CurlyPhi]]-Total[Cs[[All,1]]])/2) adj[A]/1(*Inverse[A]*);
gEval[\[ScriptCapitalE]_]:=Factor[\[ScriptCapitalE]/.{Subscript[g, \[Nu]_,\[Alpha]_,\[Beta]_]:>(G[[\[Alpha],\[Beta]]]/.T->Subscript[T, \[Nu]]),D1->\[CapitalDelta]1,D2->\[CapitalDelta]2,D3->\[CapitalDelta]3}];
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]\)\)];
If[Length[Skeleton[K]]>1,
Expand@Together@PowerExpand[{ T^(1/2)/(T-1) \[CapitalDelta],Subscript[T, 1]^(1/2)/(Subscript[T, 1]-1) Subscript[T, 2]^(1/2)/(Subscript[T, 2]-1) Subscript[T, 3]^(1/2)/(Subscript[T, 3]-1) z}//Factor ],
{ \[CapitalDelta], z}//Factor]
];


(* ::Input::Initialization:: *)
CompareMVA[L_]:=Simplify[{L,((\[Theta][L])[[1]])^-1 (-1)^(1+Length[Skeleton[L]]) MultivariableAlexander[L][T]/.{T[k_]:>T}}/.{T->T^2},T>0]


(* ::Input::Initialization:: *)
Subscript[Perm, n_,s_][K_]:=Nest[PermutationReplace[#,Cycles[{Table[i,{i,2n}]}]]&,K,s](*Rotate all labels around s times assuming n crossings.*)


(* ::Input::Initialization:: *)
Options[PolyPlot1]={Labeled->False};PolyPlot1[\[CapitalDelta]_,OptionsPattern[]]:=Module[{\[CapitalDelta]1,crs,m,maxc,minc,s,rect},
\[CapitalDelta]1=PowerExpand@Expand@\[CapitalDelta];
rect={{0,0},{1,0},{1,1},{0,1}};
If[\[CapitalDelta]1===0,Graphics[{White,Polygon@rect}, AspectRatio->1/5],
m=Max[-Exponent[\[CapitalDelta]1,T,Min], Exponent[\[CapitalDelta]1,T,Max]];
crs=CoefficientRules[T^m \[CapitalDelta]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};
PolyPlot2[\[Theta]_,OptionsPattern[]]:=Module[{\[Theta]1,crs,m1,m2,maxc,minc,s,hex,p},
\[Theta]1=PowerExpand@Expand@\[Theta];
If[\[Theta]1===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]1,Subscript[T, 1],Min], Exponent[\[Theta]1,Subscript[T, 1],Max]];
m2=Max[-Exponent[\[Theta]1,Subscript[T, 2],Min], Exponent[\[Theta]1,Subscript[T, 2],Max]];
crs=CoefficientRules[\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(m1\)] 
\*SubsuperscriptBox[\(T\), \(2\), \(m2\)] \[Theta]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\[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, FontSize->Scaled[1/(Max[m1,m2](10+maxc))],Text[c \!\(\*SubsuperscriptBox[\(T\), \(1\), \(x1 - m1\)]\) \!\(\*SubsuperscriptBox[\(T\), \(2\), \(x2 - m2\)]\),p]}]
}
},ImagePadding->None,PlotRangePadding->None]
]];
PolyPlot[{\[CapitalDelta]_,\[Theta]_},opts___Rule]:=GraphicsColumn[
{PolyPlot1[\[CapitalDelta],FilterRules[{opts},Options[PolyPlot1]]],
PolyPlot2[\[Theta],FilterRules[{opts},Options[PolyPlot2]]]},
Spacings -> Scaled@0.08,ImagePadding->None,PlotRangePadding->None,
FilterRules[{opts},Options[GraphicsColumn]]
];



