(* ::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[GST48]=PD[X[1,15,2,14],X[29,2,30,3],X[40,4,41,3],X[4,44,5,43],X[5,26,6,27],X[95,7,96,6],X[7,1,8,96],X[8,14,9,13],X[28,9,29,10],X[41,11,42,10],X[11,43,12,42],X[12,27,13,28],X[15,31,16,30],X[61,16,62,17],X[72,17,73,18],X[83,18,84,19],X[34,20,35,19],X[20,89,21,90],X[92,21,93,22],X[22,79,23,80],X[23,68,24,69],X[24,57,25,58],X[56,25,57,26],X[31,63,32,62],X[32,74,33,73],X[33,85,34,84],X[35,50,36,51],X[81,37,82,36],X[70,38,71,37],X[59,39,60,38],X[54,39,55,40],X[55,45,56,44],X[45,59,46,58],X[46,70,47,69],X[47,81,48,80],X[91,49,92,48],X[49,91,50,90],X[82,52,83,51],X[71,53,72,52],X[60,54,61,53],X[74,63,75,64],X[85,64,86,65],X[65,76,66,77],X[66,87,67,88],X[94,67,95,68],X[86,75,87,76],X[77,88,78,89],X[93,78,94,79]];


(* ::Input::Initialization:: *)
ThinPosition[K_]:=Module[{todo,done,pd,c},
todo=List@@PD@K; done={}; pd=PD[];
While[todo=!={},
AppendTo[pd,c=RandomChoice@MaximalBy[todo, Length[done\[Intersection]List@@#]&]];
todo=DeleteCases[todo, c];
done=done\[Union]List@@c];
pd ]


(* ::Input::Initialization:: *)
RVK::usage="RVK[xs, rots] represents a Rotational Virtual Knot with a list of n Xp/Xm crossings xs and a length 2n list of rotation numbers rots. Crossing sites are indexed 1 through 2n, and rots\[LeftDoubleBracket]k\[RightDoubleBracket] is the rotation between site k-1 and site k. RVK is also a casting operator converting to the RVK presentation from other knot presentations.";


(* ::Input::Initialization:: *)
RVK[pd_PD]:=Module[{n,xs,x,rots,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]];
]
];
RVK[xs,rots] ];
RVK[K_]:=RVK[PD[K]];


(* ::Input::Initialization:: *)
Subscript[rot, i_][n_]:=(*Subscript[rot, i][n]=*)\[Piecewise]{
 {Subscript[\[Eta], i], n==0},
 {Subscript[C, $]Subscript[rot, i][n-1]// Subscript[m, i,$->i], n>0},
 {Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), $]Subscript[rot, i][n+1]// Subscript[m, i,$->i], n<0}
}


(* ::Input::Initialization:: *)
Z[K_] := Z[RVK@K];
Z[rvk_RVK] :=Module[{\[Zeta],done,st,c, \[Chi],i,j,k},
\[Zeta]=1; done={}; st=Range[2Length[rvk[[1]]]];
Do[
{i,j}=List@@c;
\[Chi]=c/.{_Xp:>Subscript[R, i,j],_Xm:>Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), i,j]};
Do[\[Chi]=(Subscript[rot, 0][rvk[[2,k]]]\[Chi])//Subscript[m, 0,k->k], {k,{i,j}}];
\[Zeta]*=\[Chi];
Do[
If[MemberQ[done, k+1],\[Zeta]=\[Zeta]//Subscript[m, k,k+1->k]; st=st/.k+1->k];
If[MemberQ[done, k-1],\[Zeta]=\[Zeta]//Subscript[m, st[[k-1]],k->st[[k-1]]]; st=st/.k->st[[k-1]]],
{k,{i,j}}];
done=done\[Union]{i,j},
{c,rvk[[1]]}
];
Factor@\[Zeta]
]


(* ::Input::Initialization:: *)
ZF[K_]:=Z@ThinPosition@K;


$k=1;


(* ::Input::Initialization:: *)
CCF[\[ScriptCapitalE]_] := ExpandDenominator@ExpandNumerator@Together[\[ScriptCapitalE]];


(* ::Input::Initialization:: *)
CF[\[ScriptCapitalE]_List]:=CF/@\[ScriptCapitalE];
CF[\[ScriptCapitalE]_\[Epsilon]Series]:=CF/@\[ScriptCapitalE];
CF[\[ScriptCapitalE]_] :=Module[
{vs=Cases[\[ScriptCapitalE],Subscript[(p|x|\[Pi]|\[Xi]), _],\[Infinity]]\[Union]{p|x|\[Pi]|\[Xi]}},
Total[CoefficientRules[Expand[\[ScriptCapitalE]], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))]
];
CF[\[ScriptCapitalE]_\[DoubleStruckCapitalE]]:=CF/@\[ScriptCapitalE];
CF[\[Gamma]_\[CapitalGamma]]:=CF/@\[Gamma]; 
CF[Subscript[\[DoubleStruckCapitalE], sp___][\[ScriptCapitalE]s___]]:=CF/@Subscript[\[DoubleStruckCapitalE], sp][\[ScriptCapitalE]s];


(* ::Input::Initialization:: *)
\[Epsilon]Series/: S1_\[Epsilon]Series\[Congruent]S2_\[Epsilon]Series:=Length[S1]==Length[S2]\[And]Inner[CF[#1]==CF[#2]&,S1,S2,And];
\[Epsilon]Series[0]:=\[Epsilon]Series@@Table[0,$k+1];
\[Epsilon]Series/: S1_\[Epsilon]Series+S2_\[Epsilon]Series := \[Epsilon]Series@@Table[S1[[k]]+S2[[k]],{k,Min[Length@S1,Length@S2]}];
\[Epsilon]Series/: S1_\[Epsilon]Series*S2_\[Epsilon]Series := \[Epsilon]Series@@Table[Sum[S1[[j+1]]*S2[[k-j+1]], {j,0,k}],{k,0,Min[Length@S1,Length@S2]-1}];
\[Epsilon]Series /:c_*S_\[Epsilon]Series:=(c #)& /@ S;
\[Epsilon]Series/:\!\(
\*SubscriptBox[\(\[PartialD]\), \(vs___\)]S_\[Epsilon]Series\):=(s|->\!\(
\*SubscriptBox[\(\[PartialD]\), \(vs\)]s\))/@S;


(* ::Input::Initialization:: *)
{SuperStar[p],SuperStar[x],SuperStar[\[Pi]],SuperStar[\[Xi]]}={\[Pi],\[Xi],p,x}; 
SuperStar[(vs_List)]:=(v|->SuperStar[v])/@vs;
SuperStar[(Subscript[u_, i_])]:=Subscript[(SuperStar[u]), i];


(* ::Input::Initialization:: *)
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][\[Omega]1_,Q1_,P1_]\[Congruent]\[DoubleStruckCapitalE][\[Omega]2_,Q2_,P2_]:=CF[\[Omega]1==\[Omega]2]\[And]CF[Q1==Q2]\[And](P1\[Congruent]P2);
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][\[Omega]1_,Q1_,P1_]\[DoubleStruckCapitalE][\[Omega]2_,Q2_,P2_]:=\[DoubleStruckCapitalE][\[Omega]1 \[Omega]2,Q1+Q2,P1+P2];
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]\[Congruent]Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] ^:= (d1==d2)\[And](r1==r2)\[And](\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]\[Congruent]\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]);
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] ^:= Subscript[\[DoubleStruckCapitalE], (d1\[Union]d2)->(r1\[Union]r2)]@@(\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]);


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Zip1\), \({}\)]\)=Identity;
Subscript[Zip1, vs_]@\[LeftAngleBracket]\[ScriptCapitalF]_,\[DoubleStruckCapitalE][\[Omega]_,Q_,P_]\[RightAngleBracket] := Module[{\[ScriptCapitalI],F,G,u,v},
\[ScriptCapitalI]=IdentityMatrix@Length@vs;
F=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\[ScriptCapitalF]\),{u,SuperStar[vs]},{v,SuperStar[vs]}];
G=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]Q\),{u,vs},{v,vs}];
CF/@\[LeftAngleBracket]
SuperStar[vs] . F . Inverse[\[ScriptCapitalI]-G . F] . SuperStar[vs]/2,
\[DoubleStruckCapitalE][PowerExpand@Factor[\[Omega]  Det[\[ScriptCapitalI]- G . F]^(-1/2)],Q-vs . G . vs/2,P]
\[RightAngleBracket]
]


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Zip2\), \({}\)]\)=Identity;
Subscript[Zip2, vs_]@\[LeftAngleBracket]\[ScriptCapitalF]_,\[DoubleStruckCapitalE][\[Omega]_,Q_,P_]\[RightAngleBracket] := Module[{F,Y,u,v},
F=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\[ScriptCapitalF]\),{u,SuperStar[vs]},{v,SuperStar[vs]}];
Y=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]Q\),{v,vs}];
CF/@\[LeftAngleBracket]\[ScriptCapitalF], \[DoubleStruckCapitalE][\[Omega],Q-Y . vs+Y . F . Y/2, P/.Thread[vs->vs+F . Y]]\[RightAngleBracket]
]


(* ::Input::Initialization:: *)
Subscript[Zip3, vs_]@\[LeftAngleBracket]\[ScriptCapitalF]_,\[DoubleStruckCapitalE][\[Omega]_,Q_,P_]\[RightAngleBracket] := Module[{Z,u,v,m,j},
Z[0]=P;
For[m=0,m<2$k,++m,
Z[m+1]=CF[1/(2(m+1)) Sum[\!\(
\*SubscriptBox[\(\[PartialD]\), \(
\*SuperscriptBox[\(u\), \(*\)], 
\*SuperscriptBox[\(v\), \(*\)]\)]\[ScriptCapitalF]\)(\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\(Z[m]\)\)+Sum[(\!\(
\*SubscriptBox[\(\[PartialD]\), \(u\)]\(Z[j]\)\))(\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]\(Z[m - j]\)\)),{j,0,m}]),{u,vs},{v,vs}]]
];
\[DoubleStruckCapitalE][\[Omega],Q,CF[Sum[Z[m],{m,0,2$k}]/.Table[v->0,{v,vs}]]]
]


(* ::Input::Initialization:: *)
Subscript[Zip, vs_][\[ScriptCapitalF]_,\[ScriptCapitalE]_]:=\[LeftAngleBracket]\[ScriptCapitalF],\[ScriptCapitalE]\[RightAngleBracket]//Subscript[Zip1, vs]//Subscript[Zip2, vs]//Subscript[Zip3, vs]


(* ::Input::Initialization:: *)
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]//Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] :=Module[{is=r1\[Intersection]d2,lvs},
lvs=Flatten@Table[{Subscript[x, $@i],Subscript[p, $@i]},{i,is}];
Subscript[\[DoubleStruckCapitalE], (d1\[Union]Complement[d2,is])->(r2\[Union]Complement[r1,is])]@@(Subscript[Zip, lvs\[Union]SuperStar[lvs]][SuperStar[lvs] . lvs,Times[
\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]/.Table[Subscript[(v:x|p), i]->Subscript[v, $@i],{i,is}],
\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]/.Table[Subscript[(v:\[Xi]|\[Pi]), i]->Subscript[v, $@i],{i,is}]
]])
]


(* ::Input::Initialization:: *)
Subscript[\[Eta], i_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i}\)]\)[1,0,\[Epsilon]Series[0]];
Subscript[m, i_,j_->k_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i, j} \[Rule] {k}\)]\)[1,-Subscript[\[Xi], i] Subscript[\[Pi], j]+(Subscript[\[Pi], i]+Subscript[\[Pi], j])Subscript[p, k]+(Subscript[\[Xi], i]+Subscript[\[Xi], j])Subscript[x, k],\[Epsilon]Series[0]]


(* ::Input::Initialization:: *)
AllMonomials[{},0]={1};
AllMonomials[{},d_Integer] /; d>0 := {};
AllMonomials[{v_,vs___},d_Integer] := Join@@Table[v^(d-k) AllMonomials[{vs},k],{k,0,d}];
AllMonomials[vs_List, {d_}] := Join@@Table[AllMonomials[vs,k],{k,0,d}];


(* ::Input::Initialization:: *)
Basis[js_List,m_]:=Flatten@Outer[Times,AllMonomials[Table[Subscript[p, j],{j,js}],m],AllMonomials[Table[Subscript[x, j],{j,js}],m]];
Basis[js_List,{m_}]:=Flatten@Table[Basis[js,k],{k,0,m}]


(* ::Input::Initialization:: *)
GenericCombination[bas_,c_]:=bas . Table[Subscript[c, j],{j,Length@bas}];
GenericCombination[bas_,Subscript[c_, k_]]:=bas . Table[Subscript[c, k,j],{j,Length@bas}];


(* ::Input::Initialization:: *)
Subscript[R0, i_,j_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i, j}\)]\)[T^(1/2),(T-1)(Subscript[p, i]-Subscript[p, j]) Subscript[x, j] ,\[Epsilon]Series@@Table[0,$k+1]];
Subscript[Rp, i_,j_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i, j}\)]\)[1,0,\[Epsilon]Series@@Prepend[0]@Table[GenericCombination[Basis[{i,j},{k+1}],Subscript[c, k]],{k,$k}]];Subscript[R, i_,j_]:=Module[{i1,j1}, Subscript[R0, i,j] Subscript[Rp, i1,j1]//Subscript[m, i,i1->i]//Subscript[m, j,j1->j]];


(* ::Input::Initialization:: *)
Subscript[\!\(\*OverscriptBox[\(R0\), \(_\)]\), i_,j_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i, j}\)]\)[T^(-1/2),(T^-1-1)(Subscript[p, i]-Subscript[p, j]) Subscript[x, j] ,\[Epsilon]Series@@Table[0,$k+1]];
Subscript[\!\(\*OverscriptBox[\(Rp\), \(_\)]\), i_,j_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i, j}\)]\)[1,0,\[Epsilon]Series@@Prepend[0]@Table[GenericCombination[Basis[{i,j},{k+1}],Subscript[d, k]],{k,$k}]];Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), i_,j_]:=Module[{i1,j1}, Subscript[\!\(\*OverscriptBox[\(R0\), \(_\)]\), i,j] Subscript[\!\(\*OverscriptBox[\(Rp\), \(_\)]\), i1,j1]//Subscript[m, i,i1->i]//Subscript[m, j,j1->j]];


(* ::Input::Initialization:: *)
Subscript[C, i_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i}\)]\)[T^(1/2),0,\[Epsilon]Series@@Prepend[0]@Table[GenericCombination[Basis[{i},{k+1}],Subscript[e, k]],{k,$k}]];
Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), i_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i}\)]\)[T^(-1/2),0,\[Epsilon]Series@@Prepend[0]@Table[GenericCombination[Basis[{i},{k+1}],Subscript[f, k]],{k,$k}]];


(* ::Input::Initialization:: *)
RMoves:={
(Subscript[R, 1,2] Subscript[R, 4,3] Subscript[R, 5,6]//Subscript[m, 1,4->1]//Subscript[m, 2,5->2]//Subscript[m, 3,6->3])\[Congruent](Subscript[R, 2,3] Subscript[R, 4,5] Subscript[R, 1,6]//Subscript[m, 1,4->1]//Subscript[m, 2,5->2]//Subscript[m, 3,6->3]),
(Subscript[R, 1,2] Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), 3,4]//Subscript[m, 1,3->1]//Subscript[m, 2,4->2])\[Congruent](Subscript[\[Eta], 1] Subscript[\[Eta], 2]),
(Subscript[C, 1] Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), 2]//Subscript[m, 1,2->1] )\[Congruent]Subscript[\[Eta], 1],
(Subscript[R, 1,4] Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), 5,2] Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), 3]//Subscript[m, 2,4->2]//Subscript[m, 1,3->1]//Subscript[m, 1,5->1])\[Congruent]Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), 1] Subscript[\[Eta], 2],
(Subscript[C, 3] Subscript[R, 1,2]//Subscript[m, 2,3->2]//Subscript[m, 2,1->1])\[Congruent](Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), 3] Subscript[R, 1,2]//Subscript[m, 1,3->1]//Subscript[m, 1,2->1]),
(Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), 2] Subscript[R, 1,3]//Subscript[m, 1,2->1]//Subscript[m, 1,3->1])\[Congruent]Subscript[\[Eta], 1], (Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), 2] Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), 3,1]//Subscript[m, 1,2->1]//Subscript[m, 1,3->1])\[Congruent]Subscript[\[Eta], 1],
(Subscript[C, 2] Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), 1,3]//Subscript[m, 1,2->1]//Subscript[m, 1,3->1])\[Congruent]Subscript[\[Eta], 1],(Subscript[C, 2] Subscript[R, 3,1]//Subscript[m, 1,2->1]//Subscript[m, 1,3->1])\[Congruent]Subscript[\[Eta], 1]
}



