(* ::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:: *)
(*Please ignore*)
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:: *)
(*The formulas*)
Subscript[T, 3]=Subscript[T, 1] Subscript[T, 2];
Subscript[R, 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\)]\)-(\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(s\)] - 1\))(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] + 1\)) Subscript[g, 1\[InvisibleComma]j\[InvisibleComma]i]+(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] - 2\))Subscript[g, 2\[InvisibleComma]j\[InvisibleComma]j]+Subscript[g, 2\[InvisibleComma]i\[InvisibleComma]j]))/(\!\(
\*SubsuperscriptBox[\(T\), \(2\), \(s\)] - 1\)))];
\[Theta][{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[\[CapitalGamma], 1][\[CurlyPhi]_,k_]=-\[CurlyPhi]/2+\[CurlyPhi] Subscript[g, 3\[InvisibleComma]k\[InvisibleComma]k];


(* ::Input::Initialization:: *)
(*The main program*)
\[Theta][K_PD]:=\[Theta][Rot[K]]
\[Theta][{Cs_,\[CurlyPhi]_}]:=Module[{n,A,s,i,j,k,\[CapitalDelta],G,\[Nu],\[Alpha],\[Beta],gEval,c,z},
 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]_]:=Factor[\[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}//Factor ];


(* ::Input::Initialization:: *)
(*For plotting the output nicely*)
PolyPlot[{\[CapitalDelta]_,\[Theta]_}]:=Module[{crs,m,m1,m2,maxc,minc,s,,rect,hex},GraphicsColumn[{
rect={{0,0},{1,0},{1,1},{0,1}};
hex=Table[{Cos[\[Alpha]],Sin[\[Alpha]]}/Cos[2\[Pi]/12]/2, {\[Alpha],2\[Pi]/12,2\[Pi],2\[Pi]/6}];
If[Expand[\[CapitalDelta]]===0,Graphics[],
crs=CoefficientRules[T^(m=-Exponent[\[CapitalDelta],T,Min]) \[CapitalDelta],{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]],
Polygon[({x+m-1/2,0}+#)&/@rect] }, AspectRatio->1/5 ]
],
If[Expand[\[Theta]]===0,Graphics[{White,Disk[]}],
crs=CoefficientRules[\!\(
\*SubsuperscriptBox[\(T\), \(1\), \(m1 = \(-Exponent[\[Theta], 
\*SubscriptBox[\(T\), \(1\)], Min]\)\)] 
\*SubsuperscriptBox[\(T\), \(2\), \(m2 = \(-Exponent[\[Theta], 
\*SubscriptBox[\(T\), \(2\)], Min]\)\)] \[Theta]\),{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[{{White,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]],
Polygon[(({
 {1, -1/2},
 {0, Sqrt[3]/2}
}) . {x1-m1,x2-m2}+#)&/@hex] }
}]
]
},Spacings -> 0]];


(* ::Input::Initialization:: *)
PositiveQ[X[a_,b_,c_,d_]]:=If[b<d,False,True]
Rot[pd_PD]:=Module[{n,xs,x,rots,Xp,Xm,front={1},k},
n=Length@pd;rots=Table[0,{2n}];
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:: *)
(*m,n, even, by default all xings positive.  The list negxs flips the sign of those crossings.*)
Mat[m_,n_,negxs_:{}]:=Module[{pd},pd=(Flatten@Table[
Switch[
{EvenQ[x],EvenQ[y]},
{True,True},
X[m n+y m+m-x-1,n x+y+1,m n+y m+m-x,n x+y],
{True,False},
X[n x +y,m n+y m+x+1,n x+y+1,m n+y m+x],
{False,True},
X[n x+n-y-1,m n+y m+m-x,n x+n-y,m n+y m+m-x-1],
{False,False},
X[m n+y m+x,n x+n-y,m n+y m+x+1,n x+n-y-1]
]
,{x,0,m-1},{y,0,n-1}]
)/.{X[a_,b_,c_,d_]:>X[a+1,b+1,c+1,d+1]};
Do[pd[[i]]=(pd[[i]]/.{X[a_,b_,c_,d_]:>X[d,a,b,c]}),{i,negxs}];
PD@@pd
]
(*Randomly assign signs to all crossings*)
RandMat[m_,n_]:=Mat[m,n,RandomSample[Range[m n],RandomInteger[{0,m n}]]]



(* ::Input::Initialization:: *)
DrawXing[x_,y_,cut_]:=If[cut==="v",{Line[{{x,y-1/2},{x,y-1/4}}],Line[{{x,y+1/4},{x,y+1/2}}],Line[{{x-1/2,y},{x+1/2,y}}]},{Line[{{x,y-1/2},{x,y+1/2}}],Line[{{x-1/2,y},{x-1/4,y}}],Line[{{x+1/4,y},{x+1/2,y}}]}]


(* ::Input::Initialization:: *)
DrawMat[m_,n_,negxs_:{}]:=Graphics[{
Table[
Switch[
{EvenQ[x],EvenQ[y]},
{True,True},
DrawXing[x,y,If[MemberQ[negxs,y m+x+1],"v","h"]],
{True,False},
DrawXing[x,y,If[MemberQ[negxs,y m+x+1],"h","v"]],
{False,True},
DrawXing[x,y,If[MemberQ[negxs,y m+x+1],"h","v"]],
{False,False},
DrawXing[x,y,If[MemberQ[negxs,y m+x+1],"v","h"]]
]
,{x,0,m-1},{y,0,n-1}],
Table[{Arrowheads[{{0,.7}}],Arrow[BezierCurve[{{x,-1/2},{x,-1},{x+1,-1},{x+1,-1/2}}]]},{x,1,m-3,2}],
Table[{Arrowheads[{{0,.7}}],Arrow[BezierCurve[{{x,n-1/2},{x,n},{x+1,n},{x+1,n-1/2}}]]},{x,0,m-2,2}],
Table[{Arrowheads[{{0,.7}}],Arrow[BezierCurve[{{-1/2,y},{-1,y},{-1,y+1},{-1/2,y+1}}]]},{y,0,n-2,2}],
Table[{Arrowheads[{{0,.7}}],Arrow[BezierCurve[{{m+-1/2,y},{m,y},{m,y+1},{m+-1/2,y+1}}]]},{y,1,n-3,2}],
BezierCurve[{{m-1,-1/2},{m-1,-1},{m,0},{m-1/2,0}}],
{Arrowheads[{{0,1}}],Arrow[{{m-1/2,n-1},{m,n-1}}]},
{Arrowheads[{{0,0.5}}],Arrow[{{0,-1},{0,-1/2}}]}

}]
DrawRandMat[m_,n_]:=DrawMat[m,n,RandomSample[Range[m n],RandomInteger[m n]]]


(* ::Input::Initialization:: *)
RandMatPair[m_,n_]:=Module[{nxs=RandomSample[Range[m n],RandomInteger[m n]]},{DrawMat[m,n,nxs],PolyPlot@\[Theta]@Mat[m,n,nxs]}
]



