(* ::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:: *)
\[Chi][cond_]:=If[TrueQ[cond],1,0];


(* ::Input::Initialization:: *)
\[ScriptCapitalE]_//m[i_,j_->k_]:=Expand[Expand[\[ScriptCapitalE]]/.Subscript[e, r_,s_,t_][i]Subscript[e, u_,v_,w_][j]:>\[Chi][t==v](-1)^(u(s+t)) Subscript[e, (r+u)~Mod~2,s,w][k]]


(* ::Input::Initialization:: *)
KBasis[{i_}]:={Subscript[e, 0,0,0][i],Subscript[e, 0,0,1][i],Subscript[e, 0,1,0][i],Subscript[e, 0,1,1][i],Subscript[e, 1,0,0][i],Subscript[e, 1,0,1][i],Subscript[e, 1,1,0][i],Subscript[e, 1,1,1][i]}
KBasis[{i_,is__}]:=Flatten@Outer[Times,KBasis[{i}],KBasis[{is}]]


(* ::Input::Initialization:: *)
\[Eta][i_]:=Subscript[e, 0,0,0][i]+Subscript[e, 0,1,1][i];
\[Gamma][i_]:=Subscript[e, 1,0,0][i]+Subscript[e, 1,1,1][i];


(* ::Input::Initialization:: *)
R[i_,j_]:=Subscript[e, 0,0,0][i]Subscript[e, 0,0,0][j]+Subscript[e, 0,1,1][i]Subscript[e, 0,0,0][j]+T Subscript[e, 0,0,0][i]Subscript[e, 0,1,1][j]-(1- T)Subscript[e, 1,1,0][i]Subscript[e, 1,0,1][j]-T Subscript[e, 0,1,1][i]Subscript[e, 0,1,1][j]


(* ::Input::Initialization:: *)
\!\(\*OverscriptBox[\(R\), \(_\)]\)[i_,j_]:=Subscript[e, 0,0,0][i]Subscript[e, 0,0,0][j]+Subscript[e, 0,1,1][i]Subscript[e, 0,0,0][j]+T^-1 Subscript[e, 0,0,0][i]Subscript[e, 0,1,1][j]-(1-T^-1)Subscript[e, 1,1,0][i]Subscript[e, 1,0,1][j]-T^-1 Subscript[e, 0,1,1][i]Subscript[e, 0,1,1][j]


(* ::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={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:: *)
Kink[i_]:=Kink[i]=R[1,3]\[Gamma][2]//m[1,2->1]//m[1,3->i];
\!\(\*OverscriptBox[\(Kink\), \(_\)]\)[i_]:=\!\(\*OverscriptBox[\(Kink\), \(_\)]\)[i]=\!\(\*OverscriptBox[\(R\), \(_\)]\)[1,3]\[Gamma][2]//m[1,2->1]//m[1,3->i];


(* ::Input::Initialization:: *)
rot[i_,n_]:=\[Piecewise]{
 {\[Eta][i], EvenQ[n]},
 {\[Gamma][i], OddQ[n]}
}


(* ::Input::Initialization:: *)
Z[K_] := Z[RVK@K];
Z[rvk_RVK] := Module[{todo,n,rots,\[Zeta],done,st,cx, \[Zeta]1, i,j,k,k1,k2,k3},
{todo,rots}=List@@rvk;
AppendTo[rots,0];
n=Length[todo];
\[Zeta]=\[Eta][0];
done={0};
st=Range[0,2n+1];
While[{}=!=todo,
{cx}=MaximalBy[todo, Length[done\[Intersection]{#[[1]], #[[2]], #[[1]]-1,#[[2]]-1}]&,1];
{i,j}=List@@cx;
\[Zeta]1=Switch[Head[cx],
 Xp, (R[i,j]\!\(\*OverscriptBox[\(Kink\), \(_\)]\)[k])//m[j,k->j],
 Xm, (\!\(\*OverscriptBox[\(R\), \(_\)]\)[i,j]Kink[k])//m[j,k->j]
];
\[Zeta]1=(rot[k,rots[[i]]]\[Zeta]1)//m[k,i->i]; rots[[i]]=0;
\[Zeta]1=(\[Zeta]1 rot[k, rots[[i+1]]])//m[i,k->i]; rots[[i+1]]=0;
\[Zeta]1=(rot[k,rots[[j]]]\[Zeta]1)//m[k,j->j]; rots[[j]]=0;
\[Zeta]1=(\[Zeta]1 rot[k, rots[[j+1]]])//m[j,k->j]; rots[[j+1]]=0;
\[Zeta]*=\[Zeta]1;
If[MemberQ[done, i], \[Zeta]=\[Zeta]//m[i,i+1->i]; st=st/.st[[i+2]]->st[[i+1]]];
If[MemberQ[done, i-1],  \[Zeta]=\[Zeta]//m[st[[i]],i->st[[i]]]; st=st/.st[[i+1]]->st[[i]]]; 
If[MemberQ[done, j],  \[Zeta]=\[Zeta]//m[j,j+1->j]; st=st/.st[[j+2]]->st[[j+1]]]; 
If[MemberQ[done, j-1],  \[Zeta]=\[Zeta]//m[st[[j]],j->st[[j]]]; st=st/.st[[j+1]]->st[[j]]];
done=done\[Union]{i-1,i,j-1,j};
todo=DeleteCases[todo, cx]
];
Factor@\[Zeta]
]



