Once[<<KnotTheory`];
Once[<<"../Projects/Profile/Profile.m"]

Rotational Virtual Knots

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[[k]] 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.";
RVK[pd_PD] := Module[{n,xs,x,rots,front,k},
n=Length[pd];
xs=List@@pd /. x_X :> If[PositiveQ[x], Xp[x[[4]],x[[1]]], Xm[x[[2]],x[[1]]]];
rots=Table[0, {2n}];
front={0};
For[k=0, k<2n, ++k,
If[k==0∨FreeQ[front, -k],
front = Flatten[front /. k->Catch[xs /. {
Xp[k+1,l_]|Xm[l_,k+1] :> Throw[{l,k+1,1-l}],
Xp[l_,k+1]|Xm[k+1,l_] :> (++rots[[l]]; Throw[{1-l,k+1,l}])
}]],
If[MatchQ[front,{___,k,___,-k,___}], --rots[[k+1]]]
]
];
RVK[xs,rots]
];
RVK[K_] := RVK[PD[K]];

Z

(Subscript[ul, _])=(Subscript[nl, _])=rot[_,0] = 𝔼[1,0,0,0];
rot[i_,1] := (Subscript[ur, i]);
rot[i_,n_Integer] /; n>1 := Module[{y}, rot[i,n-1]rot[y,1] // (Subscript[m, i,y->i])];
rot[i_,-1] := (Subscript[nr, i]);
rot[i_,n_Integer] /; n<-1 := Module[{y}, rot[i,n+1]rot[y,-1] // (Subscript[m, i,y->i])];

(Subscript[t, _])=t;
Z[K_] := Z[RVK@K];
Z[rvk_RVK] := (Subscript[PP, z])@Module[{todo,n,rots,ζ,done,st,x, ζ1, i,j,k,k1,k2,k3},
{todo,rots}=List@@rvk;
AppendTo[rots,0];
n=Length[todo];
ζ=𝔼[1,0,0,0];
done={0};
st=Range[0,2n+1];
While[todo=!={},
{x}=MaximalBy[todo, Length[done⋂{#[[1]], #[[2]], #[[1]]-1,#[[2]]-1}]&,1];
Z$todo=todo; Z$x=x;
{i,j}=List@@x;
ζ1=Switch[Head[x],
 Xp, (Subscript[m, j,k->j])[(Subscript[R, i,j]^(+))((Subscript[R, k3,k]^(-))(Subscript[nr, k1])(Subscript[ul, k2])//(Subscript[m, k,k1->k])//(Subscript[m, k,k2->k])//(Subscript[m, k,k3->k]))],
 Xm, (Subscript[m, j,k->j])[(Subscript[R, i,j]^(-))((Subscript[R, k,k3]^(+))(Subscript[nr, k1])(Subscript[ul, k2])//(Subscript[m, k,k1->k])//(Subscript[m, k,k2->k])//(Subscript[m, k,k3->k]))]
];
ζ1=rot[k,rots[[i]]]ζ1 // (Subscript[m, k,i->i]); rots[[i]]=0;
ζ1=ζ1 rot[k, rots[[i+1]]] // (Subscript[m, i,k->i]); rots[[i+1]]=0;
ζ1=rot[k,rots[[j]]]ζ1 // (Subscript[m, k,j->j]); rots[[j]]=0;
ζ1=ζ1 rot[k, rots[[j+1]]] // (Subscript[m, j,k->j]); rots[[j+1]]=0;
ζ*=ζ1;
If[MemberQ[done, i],  ζ=ζ//(Subscript[m, i,i+1->i]); st=st/.st[[i+2]]->st[[i+1]]];
If[MemberQ[done, i-1],  ζ=ζ//(Subscript[m, st[[i]],i->st[[i]]]); st=st/.st[[i+1]]->st[[i]]]; 
If[MemberQ[done, j],  ζ=ζ//(Subscript[m, j,j+1->j]); st=st/.st[[j+2]]->st[[j+1]]]; 
If[MemberQ[done, j-1],  ζ=ζ//(Subscript[m, st[[j]],j->st[[j]]]); st=st/.st[[j+1]]->st[[j]]];
done=done⋃{i-1,i,j-1,j};
todo=DeleteCases[todo, x]
];
ζ /. {(Subscript[e, 0])->e,(Subscript[l, 0])->l,(Subscript[f, 0])->f}
]