(* ::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:: *)
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[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:: *)
Subscript[\[Delta], i_,j_]:=If[i===j,1,0];
Subscript[gRules, s_,i_,j_]:={Subscript[g, i\[InvisibleComma]\[Beta]_]:>Subscript[\[Delta], i\[InvisibleComma]\[Beta]]+T^s Subscript[g, SuperPlus[i],\[Beta]]+(1-T^s)Subscript[g, SuperPlus[j],\[Beta]],Subscript[g, j\[InvisibleComma]\[Beta]_]:>Subscript[\[Delta], j\[InvisibleComma]\[Beta]]+Subscript[g, SuperPlus[j],\[Beta]],
Subscript[g, \[Alpha]_,i]:>T^-s (Subscript[g, \[Alpha],SuperPlus[i]]-Subscript[\[Delta], \[Alpha],SuperPlus[i]]),Subscript[g, \[Alpha]_\[InvisibleComma]j]:>Subscript[g, \[Alpha],SuperPlus[j]]-(1-T^s)Subscript[g, \[Alpha]\[InvisibleComma]i]-Subscript[\[Delta], \[Alpha],SuperPlus[j]]}
Subscript[fRules, s_,i_,j_]:={Subscript[f, i\[InvisibleComma]\[Beta]_]:>Subscript[\[Delta], i\[InvisibleComma]\[Beta]]+F^s Subscript[f, SuperPlus[i],\[Beta]]+(1-F^s)Subscript[f, SuperPlus[j],\[Beta]],Subscript[f, j\[InvisibleComma]\[Beta]_]:>Subscript[\[Delta], j\[InvisibleComma]\[Beta]]+Subscript[f, SuperPlus[j],\[Beta]],
Subscript[f, \[Alpha]_,i]:>F^-s (Subscript[f, \[Alpha],SuperPlus[i]]-Subscript[\[Delta], \[Alpha],SuperPlus[i]]),Subscript[f, \[Alpha]_\[InvisibleComma]j]:>Subscript[f, \[Alpha],SuperPlus[j]]-(1-F^s)Subscript[f, \[Alpha]\[InvisibleComma]i]-Subscript[\[Delta], \[Alpha],SuperPlus[j]]}
SuperPlus[(SuperPlus[\[Alpha]_])]:=\!\(\*SuperscriptBox[\(\[Alpha]\), \("\<++\>"\)]\);


(* ::Input::Initialization:: *)
Subscript[R, 1][1,i_,j_]:=Module[{gfs=Join[Flatten@Table[Subscript[f, a,b],{a,{i,j}},{b,{i,j}}],
Flatten@Table[Subscript[g, a,b],{a,{i,j}},{b,{i,j}}]]},
DeleteDuplicates[Times@@@Tuples[
gfs,2]] . Table[Subscript[r, k],{k,36}]+
gfs . Table[Subscript[r, k],{k,36+1,36+8}]+ Subscript[r, 36+9]]
Subscript[R, 1][-1,i_,j_]:=Module[{gfs=Join[Flatten@Table[Subscript[f, a,b],{a,{i,j}},{b,{i,j}}],
Flatten@Table[Subscript[g, a,b],{a,{i,j}},{b,{i,j}}]]},
DeleteDuplicates[Times@@@Tuples[
gfs,2]] . Table[Subscript[q, k],{k,36}]+
gfs . Table[Subscript[q, k],{k,36+1,36+8}]+ Subscript[q, 36+9]]
(* modified expression for the curl: *)
CC[s_,i_]:=s (Subscript[c, 1 ] Subscript[f, i,i]+Subscript[c, 2] Subscript[g, i,i]+Subscript[c, 3])


(* ::Input::Initialization:: *)
lhs3=Subscript[R, 1][1,j,k]+Subscript[R, 1][1,i,SuperPlus[k]]+Subscript[R, 1][1,SuperPlus[i],SuperPlus[j]]//.Subscript[gRules, 1,j,k]\[Union]Subscript[gRules, 1,i,SuperPlus[k]]\[Union]Subscript[gRules, 1,SuperPlus[i],SuperPlus[j]]\[Union]Subscript[fRules, 1,j,k]\[Union]Subscript[fRules, 1,i,SuperPlus[k]]\[Union]Subscript[fRules, 1,SuperPlus[i],SuperPlus[j]];
rhs3=Subscript[R, 1][1,i,j]+Subscript[R, 1][1,SuperPlus[i],k]+Subscript[R, 1][1,SuperPlus[j],SuperPlus[k]]//.Subscript[gRules, 1,i,j]\[Union]Subscript[gRules, 1,SuperPlus[i],k]\[Union]Subscript[gRules, 1,SuperPlus[j],SuperPlus[k]]\[Union]Subscript[fRules, 1,i,j]\[Union]Subscript[fRules, 1,SuperPlus[i],k]\[Union]Subscript[fRules, 1,SuperPlus[j],SuperPlus[k]];

lhs2c=Subscript[R, 1][-1,i,SuperPlus[j]]+Subscript[R, 1][1,SuperPlus[i],j]+CC[1,SuperPlus[j]]//.Subscript[gRules, -1,i,SuperPlus[j]]\[Union]Subscript[gRules, 1,SuperPlus[i],j]\[Union]Subscript[fRules, -1,i,SuperPlus[j]]\[Union]Subscript[fRules, 1,SuperPlus[i],j];
rhs2c=CC[1,SuperPlus[(SuperPlus[j])]];

lhs1l=Subscript[R, 1][1,SuperPlus[i],i]+CC[1,SuperPlus[i]]//.{Subscript[g, SuperPlus[i],\[Beta]_]:>T^-1 Subscript[\[Delta], SuperPlus[i],\[Beta]]+Subscript[g, \!\(\*SuperscriptBox[\(i\), \("\<++\>"\)]\),\[Beta]],Subscript[g, i,\[Beta]_]:>Subscript[\[Delta], i,\[Beta]]+Subscript[g, SuperPlus[i],\[Beta]],
Subscript[g, \[Alpha]_,SuperPlus[i]]:>T^-1 (Subscript[g, \[Alpha],\!\(\*SuperscriptBox[\(i\), \("\<++\>"\)]\)]-Subscript[\[Delta], \[Alpha],SuperPlus[i]]),Subscript[g, \[Alpha]_,i]:>T Subscript[g, \[Alpha],SuperPlus[i]]-Subscript[\[Delta], \[Alpha],SuperPlus[i]],
Subscript[f, SuperPlus[i],\[Beta]_]:>F^-1 Subscript[\[Delta], SuperPlus[i],\[Beta]]+Subscript[f, \!\(\*SuperscriptBox[\(i\), \("\<++\>"\)]\),\[Beta]],Subscript[f, i,\[Beta]_]:>Subscript[\[Delta], i,\[Beta]]+Subscript[f, SuperPlus[i],\[Beta]],
Subscript[f, \[Alpha]_,SuperPlus[i]]:>F^-1 (Subscript[f, \[Alpha],\!\(\*SuperscriptBox[\(i\), \("\<++\>"\)]\)]-Subscript[\[Delta], \[Alpha],SuperPlus[i]]),Subscript[f, \[Alpha]_,i]:>T Subscript[f, \[Alpha],SuperPlus[i]]-Subscript[\[Delta], \[Alpha],SuperPlus[i]]};
lhs1r=Subscript[R, 1][1,i,SuperPlus[i]]+CC[-1,SuperPlus[i]]//.{
Subscript[g, i\[InvisibleComma]\[Beta]_]:>Subscript[\[Delta], i\[InvisibleComma]\[Beta]]+T Subscript[g, SuperPlus[i],\[Beta]]+(1-T)Subscript[g, SuperPlus[SuperPlus[i]],\[Beta]],Subscript[g, SuperPlus[i],\[Beta]_]:>Subscript[\[Delta], SuperPlus[i],\[Beta]]+Subscript[g, SuperPlus[SuperPlus[i]],\[Beta]],
Subscript[g, \[Alpha]_,i]:>T^-1 (Subscript[g, \[Alpha],SuperPlus[i]]-Subscript[\[Delta], \[Alpha],SuperPlus[i]]),Subscript[g, \[Alpha]_,SuperPlus[i]]:>T Subscript[g, \[Alpha],SuperPlus[SuperPlus[i]]]-(1-T)Subscript[\[Delta], \[Alpha],SuperPlus[i]]-T Subscript[\[Delta], \[Alpha],SuperPlus[SuperPlus[i]]],
Subscript[f, i\[InvisibleComma]\[Beta]_]:>Subscript[\[Delta], i\[InvisibleComma]\[Beta]]+F Subscript[f, SuperPlus[i],\[Beta]]+(1-F)Subscript[f, SuperPlus[SuperPlus[i]],\[Beta]],Subscript[f, SuperPlus[i],\[Beta]_]:>Subscript[\[Delta], SuperPlus[i],\[Beta]]+Subscript[f, SuperPlus[SuperPlus[i]],\[Beta]],
Subscript[f, \[Alpha]_,i]:>F^-1 (Subscript[f, \[Alpha],SuperPlus[i]]-Subscript[\[Delta], \[Alpha],SuperPlus[i]]),Subscript[f, \[Alpha]_,SuperPlus[i]]:>T Subscript[f, \[Alpha],SuperPlus[SuperPlus[i]]]-(1-F)Subscript[\[Delta], \[Alpha],SuperPlus[i]]-F Subscript[\[Delta], \[Alpha],SuperPlus[SuperPlus[i]]]};
rhs1l=0;
rhs1r=0;
lhssw=Subscript[R, 1][1,i,j]+CC[-1,i]+CC[-1,j]+CC[1,SuperPlus[i]]+CC[1,SuperPlus[j]]//.Subscript[gRules, 1,i,j]\[Union]Subscript[fRules, 1,i,j];
rhssw=Subscript[R, 1][1,i,j]//.Subscript[gRules, 1,i,j]\[Union]Subscript[fRules, 1,i,j];


(* ::Input::Initialization:: *)
V=Join[Flatten@Table[Subscript[g, a,b],{a,{\!\(\*SuperscriptBox[\(i\), \("\<++\>"\)]\),\!\(\*SuperscriptBox[\(j\), \("\<++\>"\)]\),\!\(\*SuperscriptBox[\(k\), \("\<++\>"\)]\)}},{b,{\!\(\*SuperscriptBox[\(i\), \("\<++\>"\)]\),\!\(\*SuperscriptBox[\(j\), \("\<++\>"\)]\),\!\(\*SuperscriptBox[\(k\), \("\<++\>"\)]\)}}],Flatten@Table[Subscript[f, a,b],{a,{\!\(\*SuperscriptBox[\(i\), \("\<++\>"\)]\),\!\(\*SuperscriptBox[\(j\), \("\<++\>"\)]\),\!\(\*SuperscriptBox[\(k\), \("\<++\>"\)]\)}},{b,{\!\(\*SuperscriptBox[\(i\), \("\<++\>"\)]\),\!\(\*SuperscriptBox[\(j\), \("\<++\>"\)]\),\!\(\*SuperscriptBox[\(k\), \("\<++\>"\)]\)}}]];
eq3=Thread[Last/@CoefficientRules[lhs3-rhs3,V]==0];
eq2c=Thread[Last/@CoefficientRules[lhs2c-rhs2c,V]==0];
eq1l=Thread[Last/@CoefficientRules[lhs1l-rhs1l,V]==0];
eq1r=Thread[Last/@CoefficientRules[lhs1r-rhs1r,V]==0];
eqsw=Thread[Last/@CoefficientRules[lhssw-rhssw,V]==0];


(* ::Input::Initialization:: *)
Soln=First@Solve[Join[eq3,eq2c,eq1l,eq1r,eqsw],Join[Table[Subscript[q, i],{i,1,45}],Table[Subscript[r, i],{i,1,45}],Table[Subscript[c, i],{i,1,2}]]]//Simplify


(* ::Input::Initialization:: *)
CCC[s_,i_]:=s(CC[1,i]/.Soln)
Subscript[RR, 1][1,i_,j_]:=Subscript[R, 1][1,i,j]/.Soln
Subscript[RR, 1][-1,i_,j_]:=Subscript[R, 1][-1,i,j]/.Soln
\[Rho]\[Rho][K_]:=Module[{Cs,\[CurlyPhi],n,A,s,i,j,k,\[CapitalDelta],G,FF,\[Rho]1},
{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];FF=G/.T->F;
\[Rho]1=\!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(n\)]\(
\*SubscriptBox[\(RR\), \(1\)] @@ Cs[[k]]\)\) + \!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(2  n\)]\(\[CurlyPhi][[k]] CCC[1, k]\)\);
Factor@{\[CapitalDelta],(\[CapitalDelta]^2/.T->F)\[CapitalDelta]^2 \[Rho]1/.SuperPlus[\[Alpha]_]:>\[Alpha]+1/.{Subscript[g, \[Alpha]_,\[Beta]_]:>G[[\[Alpha],\[Beta]]],Subscript[f, \[Alpha]_,\[Beta]_]:>FF[[\[Alpha],\[Beta]]]}}];
Subscript[Rold, 1][s_,i_,j_]:=s(Subscript[g, j\[InvisibleComma]i](Subscript[g, SuperPlus[j],j]+Subscript[g, j,SuperPlus[j]]-Subscript[g, i\[InvisibleComma]j])-Subscript[g, i\[InvisibleComma]i](Subscript[g, j,SuperPlus[j]]-1)-1/2);
Cold[s_,i_]:=s(-Subscript[g, i\[InvisibleComma]i]+1/2)
\[Rho][K_]:=Module[{Cs,\[CurlyPhi],n,A,s,i,j,k,\[CapitalDelta],G,FF,\[Rho]1},
{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];
\[Rho]1=\!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(n\)]\((\((
\*SubscriptBox[\(Rold\), \(1\)] @@ Cs[[k]])\))\)\)+ \!\(
\*SubsuperscriptBox[\(\[Sum]\), \(k = 1\), \(2  n\)]\(\[CurlyPhi][[k]] Cold[1, k]\)\);
Factor@{\[CapitalDelta],\[CapitalDelta]^2 \[Rho]1/.SuperPlus[\[Alpha]_]:>\[Alpha]+1/.{Subscript[g, \[Alpha]_,\[Beta]_]:>G[[\[Alpha],\[Beta]]]}}];



