(* ::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:: *)
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]:=Subscript[PP, RVK]@Module[{n,xs,x,rots,front={0},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=0,k<2n,++k,If[k==0\[Or]FreeQ[front,-k],
front=Flatten@Replace[front,k->(xs/.{
Xp[k+1,l_]|Xm[l_,k+1]:>{l,k+1,1-l},
Xp[l_,k+1]|Xm[k+1,l_]:>(++rots[[l]];{1-l,k+1,l}),
_Xp|_Xm:>{}
}), {1}],
Cases[front,k|-k]/.{k,-k}:>--rots[[k+1]];
]];
RVK[xs,rots] ];
RVK[K_]:=RVK[PD[K]];


(* ::Input::Initialization:: *)
rot[i_,0]:=Subscript[d\[Eta], i];
rot[i_,n_]:=rot[i,n,$k];
rot[i_,n_,k_]:=Module[{j},
rot[i,n,k]=If[n>0,rot[i,n-1]Subscript[kC, j],rot[i,n+1]Subscript[\!\(\*OverscriptBox[\(kC\), \(_\)]\), j]]//Subscript[km, i,j->i]];


(* ::Input::Initialization:: *)
Width[pd_PD]:=Max[Length/@FoldList[Complement[#1\[Union]#2,#1\[Intersection]#2]&, {}, List@@List@@@pd]]


(* ::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 ];
ThinPosition[K_,n_] := First@MinimalBy[Table[ThinPosition[K], n], Width];


(* ::Input::Initialization:: *)
Z[K_] := Z[RVK@EchoFunction[Width]@ThinPosition[K,100]];
Z[rvk_RVK] := Monitor[ \!\(\*SubscriptBox[\(PP\), \("\<Z\>"\)]\)@Module[{\[Zeta],done,st,c, \[Chi],i,j,k},
\[Zeta]=1; done={}; st=Range[2Length[rvk[[1]]]]; $M={};
Do[AppendTo[$M,c];
{i,j}=List@@c;
\[Chi]=(c/.{_Xp:>Subscript[kR, i,j] Subscript[\!\(\*OverscriptBox[\(kKink\), \(_\)]\), 0],_Xm:>Subscript[\!\(\*OverscriptBox[\(kR\), \(_\)]\), i,j] Subscript[kKink, 0]})//Subscript[km, j,0->j];
Do[\[Chi]=(rot[0,rvk[[2,k]]]\[Chi])//Subscript[km, 0,k->k], {k,{i,j}}];
\[Zeta]*=\[Chi];
Do[
If[MemberQ[done, k+1],\[Zeta]=\[Zeta]//Subscript[km, k,k+1->k]; st=st/.k+1->k];
If[MemberQ[done, k-1],\[Zeta]=\[Zeta]//Subscript[km, st[[k-1]],k->st[[k-1]]]; st=st/.k->st[[k-1]]],
{k,{i,j}}];
done=done\[Union]{i,j},
{c,rvk[[1]]}
];
CF/@ (\[Zeta] /. {Subscript[x, 1]->x,Subscript[y, 1]->y,Subscript[a, 1]->a})
], {Length@$M,$M}]
