(* ::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\\Talks\\LesDiablerets-2601"];
Once[<< KnotTheory`]
SetOptions[$FrontEndSession,PrintingStyleEnvironment->"Working"];


(* ::Input::Initialization:: *)
PD[epd_EPD]:=PD@@epd/.{Subscript[X, i_,j_]:>X[j,i+1,j+1,i],Subscript[\!\(\*OverscriptBox[\(X\), \(_\)]\), i_,j_]:>X[j,i,j+1,i+1]}


(* ::Input::Initialization:: *)
Rot[{X_,\[CurlyPhi]_}]:={X,\[CurlyPhi]};
Rot[pd_PD]:=Module[{n,xs,x,rots,Xp,Xm,front={1},k},
n=Length@pd;rots=Table[0,{2n+1}];
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:: *)
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[],
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, Shear->True};
PolyPlot2[\[Theta]_,OptionsPattern[]]:=Module[{\[Theta]1,crs,m1,m2,maxc,minc,s,stone,mat,p},
\[Theta]1=PowerExpand@Expand@\[Theta];
If[\[Theta]1===0,Graphics[{White,Disk[]}],
If[OptionValue[Shear],
stone=Table[{Cos[\[Alpha]],Sin[\[Alpha]]}/Cos[2\[Pi]/12]/2, {\[Alpha],2\[Pi]/12,2\[Pi],2\[Pi]/6}];
mat=({
 {1, -1/2},
 {0, Sqrt[3]/2}
}),
stone={{1,1}, {-1,1},{-1,-1},{1,-1}}/2;
mat=IdentityMatrix[2];
];
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=mat . {x1-m1,x2-m2};
Tooltip[Polygon[(p+#)&/@stone],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]
]];
Options[PolyPlot]={Labeled->False, ImageSize->Automatic};
PolyPlot[{\[CapitalDelta]_,\[Theta]_},opts___Rule]:=GraphicsColumn[
{PolyPlot1[\[CapitalDelta],FilterRules[Join[{opts},Options[PolyPlot]],Options[PolyPlot1]]],
PolyPlot2[\[Theta],FilterRules[Join[{opts},Options[PolyPlot]],Options[PolyPlot2]]]},
Spacings -> Scaled@0.08,ImagePadding->None,PlotRangePadding->None,
FilterRules[Join[{opts},Options[PolyPlot]],Options[GraphicsColumn]]
];


(* ::Input::Initialization:: *)
CF[\[ScriptCapitalE]_] := Expand@Collect[\[ScriptCapitalE],Subscript[g, __],F]/.F->Factor;
Subscript[T, 3]=Subscript[T, 1] Subscript[T, 2];

Subscript[F, 1][{s_,i_,j_}]:=CF[
s(1/2-Subscript[g, 3\[InvisibleComma]i\[InvisibleComma]i]+\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SubscriptBox[\(g\), \(1\[InvisibleComma]i\[InvisibleComma]i\)] 
\*SubscriptBox[\(g\), \(2\[InvisibleComma]j\[InvisibleComma]i\)]\)-Subscript[g, 1\[InvisibleComma]i\[InvisibleComma]i] Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]j]-(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] - 1\))Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]i] Subscript[g, 3\[InvisibleComma]i\[InvisibleComma]i]+2Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]j] Subscript[g, 3\[InvisibleComma]i\[InvisibleComma]i]-(1-\!\(\*SubsuperscriptBox[\(T\), \(3\), \(s\)]\))Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]i] Subscript[g, 3\[InvisibleComma]j\[InvisibleComma]i]-Subscript[g, 2\[InvisibleComma]i\[InvisibleComma]i] Subscript[g, 3\[InvisibleComma]j\[InvisibleComma]j]-\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SubscriptBox[\(g\), \(2\[InvisibleComma]j\[InvisibleComma]i\)] 
\*SubscriptBox[\(g\), \(3\[InvisibleComma]j\[InvisibleComma]j\)]\)+Subscript[g, 1\[InvisibleComma]i\[InvisibleComma]i] Subscript[g, 3\[InvisibleComma]j\[InvisibleComma]j]+((\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(s\)] - 1\))Subscript[g, 1\[InvisibleComma]j\[InvisibleComma]i](\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(2  s\)] 
\*SubscriptBox[\(g\), \(2\[InvisibleComma]j\[InvisibleComma]i\)]\)-\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SubscriptBox[\(g\), \(2\[InvisibleComma]j\[InvisibleComma]j\)]\)+\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SubscriptBox[\(g\), \(3\[InvisibleComma]j\[InvisibleComma]j\)]\))+(\!\(
\*SubsuperscriptBox[\(T\), \(3\), \(s\)] - 1\))Subscript[g, 3\[InvisibleComma]j\[InvisibleComma]i](1-\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] 
\*SubscriptBox[\(g\), \(1\[InvisibleComma]i\[InvisibleComma]i\)]\)+Subscript[g, 2\[InvisibleComma]i\[InvisibleComma]j]+(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] - 2\))Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]j]-(\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(s\)] - 1\))(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] + 1\)) Subscript[g, 1\[InvisibleComma]j\[InvisibleComma]i]))/(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] - 1\)))]
Subscript[F, 2][{s0_,i0_,j0_},{s1_,i1_,j1_}]:=CF[s1(\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(s0\)] - 1\))(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s1\)] - 1\))^-1 (\!\(
\*SubsuperscriptBox[\(T\), \(3\), \(s1\)] - 1\))Subscript[g, 1,j1,i0] Subscript[g, 3,j0,i1]( (\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s0\)] 
\*SubscriptBox[\(g\), \(2, i1, i0\)]\)-Subscript[g, 2,i1,j0])- (\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s0\)] 
\*SubscriptBox[\(g\), \(2, j1, i0\)]\)-Subscript[g, 2,j1,j0]))]
Subscript[F, 3][\[CurlyPhi]_,k_]=\[CurlyPhi] Subscript[g, 3\[InvisibleComma]k\[InvisibleComma]k]-\[CurlyPhi]/2;

\[CapitalTheta][K_]:=\[CapitalTheta][K]=Module[{X,\[CurlyPhi],n,A,\[CapitalDelta],G,ev,\[Theta],k,k1,k2},
{X,\[CurlyPhi]}=Rot[K]; n=Length[X]; A=IdentityMatrix[2n+1];
Cases[X,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=({
 {-T^s, T^s-1},
 {0, -1}
}))];
\[CapitalDelta]=T^((-Total[\[CurlyPhi]]-Total[X[[All,1]]])/2) Det[A];
G=Inverse[A];
ev[\[ScriptCapitalE]_]:=Factor[\[ScriptCapitalE]/.Subscript[g, \[Nu]_,\[Alpha]_,\[Beta]_]:>(G[[\[Alpha],\[Beta]]]/.T->Subscript[T, \[Nu]])];
\[Theta]=ev[Sum[Subscript[F, 1][X[[k]]], {k,n}]];
\[Theta]+=ev[Sum[Subscript[F, 2][X[[k1]],X[[k2]]], {k1,n}, {k2,n}]];
\[Theta]+=ev[Sum[Subscript[F, 3][\[CurlyPhi][[k]],k], {k,Length@\[CurlyPhi]}]];
Factor@{\[CapitalDelta],(\[CapitalDelta]/.T->Subscript[T, 1])(\[CapitalDelta]/.T->Subscript[T, 2])(\[CapitalDelta]/.T->Subscript[T, 3])\[Theta]}
];


(* ::Input::Initialization:: *)
(*L should be a list of an odd number of odd integers.*)
OddPretzel[L_]:=Module[{s=Total[Abs/@L],x},
PD@@Flatten@Table[x = Sum[Abs[L[[j]]],{j,1,u-1}];

If[EvenQ[u],
If[L[[u]]>0,
Join[Table[X[s+x+Abs[L[[u]]]-2k,x+2+2k,s+x+Abs[L[[u]]]-2k-1,x+1+2k],{k,0,(Abs[L[[u]]]-1)/2}],
Table[X[x+2k,s+x+Abs[L[[u]]]+2-2k,x+1+2k,s+x+Abs[L[[u]]]+1-2k],{k,1,(Abs[L[[u]]]-1)/2}]],
Join[Table[X[x+1+2k,s+x+Abs[L[[u]]]-2k,x+2+2k,s+x+Abs[L[[u]]]+1-2k],{k,0,(Abs[L[[u]]]-1)/2}],
Table[X[s+x+Abs[L[[u]]]+1-2k,x+2k,s+x+Abs[L[[u]]]+2-2k,x+1+2k],{k,1,(Abs[L[[u]]]-1)/2}]]]
,
If[L[[u]]>0,
Join[Table[X[x+1+2k,s+x+Abs[L[[u]]]+1-2k,x+2+2k,s+x+Abs[L[[u]]]-2k],{k,0,(Abs[L[[u]]]-1)/2}],
Table[X[s+x+Abs[L[[u]]]+1-2k,x+1+2k,s+x+Abs[L[[u]]]+2-2k,x+2k],{k,1,(Abs[L[[u]]]-1)/2}]],
Join[Table[X[s+x+Abs[L[[u]]]-2k,x+1+2k,s+x+Abs[L[[u]]]+1-2k,x+2+2k],{k,0,(Abs[L[[u]]]-1)/2}],
Table[X[x+2k,s+x+Abs[L[[u]]]+1-2k,x+1+2k,s+x+Abs[L[[u]]]+2-2k],{k,1,(Abs[L[[u]]]-1)/2}]]]
]
,{u,Length[L]}]
]


(* ::Input::Initialization:: *)
(*L should be a list L={L0,L1,..,Ln} where L0 and n>=0 are even and the Li, i>0 are odd integers.*)
EOddPretzel[LL_]:=Module[{L=Rest@LL,s,x,y,n},
s=2Abs[LL[[1]]]+Total[Abs/@L];n=Length[L];
PD@@Flatten@
Join[
If[LL[[1]]>0,
Join[Table[X[1+2k,s+1-2k,2+2k,s-2k],{k,0,Abs[LL[[1]]]/2-1}],Table[X[s+1-2k,1+2k,s+2-2k,2k],{k,1,Abs[LL[[1]]]/2}]],
Join[Table[X[s-2k,1+2k,s+1-2k,2+2k],{k,0,Abs[LL[[1]]]/2-1}],Table[X[2k,s+1-2k,1+2k,s+2-2k],{k,1,Abs[LL[[1]]]/2}]]
],
Table[x = Sum[Abs[L[[j]]],{j,u+1,n}];y= Abs[LL[[1]]]+Sum[Abs[L[[j]]],{j,1,u-1}];

If[EvenQ[u],
If[L[[u]]>0,
Join[Table[X[s+x+1+2k,y+1+2k,s+x+2+2k,y+2+2k],{k,0,(Abs[L[[u]]]-1)/2}],
Table[X[y+2k,s+x+2k,y+1+2k,s+x+1+2k],{k,1,(Abs[L[[u]]]-1)/2}]],
Join[Table[X[y+1+2k,s+x+2+2k,y+2+2k,s+x+1+2k],{k,0,(Abs[L[[u]]]-1)/2}],
Table[X[s+x+2k,y+1+2k,s+x+1+2k,y+2k],{k,1,(Abs[L[[u]]]-1)/2}]]]
,
If[L[[u]]>0,
Join[Table[X[y+1+2k,s+x+1+2k,y+2+2k,s+x+2+2k],{k,0,(Abs[L[[u]]]-1)/2}],
Table[X[s+x+2k,y+2k,s+x+1+2k,y+1+2k],{k,1,(Abs[L[[u]]]-1)/2}]],
Join[Table[X[s+x+1+2k,y+2+2k,s+x+2+2k,y+1+2k],{k,0,(Abs[L[[u]]]-1)/2}],
Table[X[y+2k,s+x+1+2k,y+1+2k,s+x+2k],{k,1,(Abs[L[[u]]]-1)/2}]]]
]
,{u,Length[L]}]
]
]



