(* ::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[
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\SL2Invariant"];
<< KnotTheory`;
<<"../Profile/Profile.m";
];
BeginProfile[];
Once@PopupWindow[Button["Show Profile Monitor"],Dynamic[PrintProfile[], UpdateInterval->3, TrackedSymbols->{}]]


(* ::Input::Initialization:: *)
HL[\[ScriptCapitalE]_] := Style[\[ScriptCapitalE], Background -> Yellow];


(* ::Input::Initialization:: *)
CF[sd_SeriesData] := MapAt[CF,sd,3];
CF[\[ScriptCapitalE]_] := Subscript[PP, CF]@ExpandDenominator@ExpandNumerator@Subscript[PP, Together]@Together[Subscript[PP, Exp][
Expand[\[ScriptCapitalE]] //. E^x_ E^y_:>E^(x+y) /. E^x_:>E^CF[x]]];


(* ::Input::Initialization:: *)
K\[Delta]/:Subscript[K\[Delta], i_,j_]:=If[i===j,1,0];


(* ::Input::Initialization:: *)
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][L1_,Q1_,P1_]\[Congruent]\[DoubleStruckCapitalE][L2_,Q2_,P2_]:=CF[L1==L2]\[And]CF[Q1==Q2]\[And]CF[Normal[P1-P2]==0];
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][L1_,Q1_,P1_]\[DoubleStruckCapitalE][L2_,Q2_,P2_]:=\[DoubleStruckCapitalE][L1+L2,Q1+Q2,P1*P2];
Subscript[\[DoubleStruckCapitalE][L_,Q_,P_], $k_]:=\[DoubleStruckCapitalE][L,Q,Series[Normal@P,{\[Epsilon],0,$k}]];


(* ::Input::Initialization:: *)
{SuperStar[t],SuperStar[b],SuperStar[y],SuperStar[a],SuperStar[x],SuperStar[z]}={\[Tau],\[Beta],\[Eta],\[Alpha],\[Xi],\[Zeta]}; 
{SuperStar[\[Tau]],SuperStar[\[Beta]],SuperStar[\[Eta]],SuperStar[\[Alpha]],SuperStar[\[Xi]],SuperStar[\[Zeta]]}={t,b,y,a,x,z}; SuperStar[(Subscript[u_, i_])]:=Subscript[(SuperStar[u]), i];


(* ::Input::Initialization:: *)
collect[sd_SeriesData, \[Zeta]_] := MapAt[collect[#,\[Zeta]]&,sd,3];
collect[\[ScriptCapitalE]_,\[Zeta]_] := Subscript[PP, Collect]@Collect[\[ScriptCapitalE],\[Zeta]];
\!\(\*SubscriptBox[\(Zip\), \({}\)]\)[P_]:=P; \!\(\*SubscriptBox[\(Zip\), \({\[Zeta]_, \[Zeta]s___}\)]\)[P_] := Subscript[PP, Zip][
(collect[P//\!\(\*SubscriptBox[\(Zip\), \({\[Zeta]s}\)]\),\[Zeta]] /. f_. \[Zeta]^d_.:>\!\(
\*SubscriptBox[\(\[PartialD]\), \({
\*SuperscriptBox[\(\[Zeta]\), \(*\)], d}\)]f\)) /. SuperStar[\[Zeta]]->0]


(* ::Input::Initialization:: *)
Subscript[QZip, \[Zeta]s_List]@\[DoubleStruckCapitalE][L_,Q_,P_] := Subscript[PP, QZip]@Module[{\[Zeta],z,zs,c,ys,\[Eta]s,qt,zrule,Q1,Q2},
zs=Table[SuperStar[\[Zeta]],{\[Zeta],\[Zeta]s}];
c=Q/.Alternatives@@(\[Zeta]s\[Union]zs)->0;
ys=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Zeta]\)]\((Q /. Alternatives @@ zs -> 0)\)\),{\[Zeta],\[Zeta]s}];
\[Eta]s=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(z\)]\((Q /. Alternatives @@ \[Zeta]s -> 0)\)\),{z,zs}];
qt=Inverse@Table[Subscript[K\[Delta], z,SuperStar[\[Zeta]]]-\!\(
\*SubscriptBox[\(\[PartialD]\), \(z, \[Zeta]\)]Q\),{\[Zeta],\[Zeta]s},{z,zs}];
zrule=Thread[zs->qt.(zs+ys)];
Q2=(Q1=c+\[Eta]s.zs/.zrule)/.Alternatives@@zs->0;
CF /@ \[DoubleStruckCapitalE][L,Q2,Det[qt]E^-Q2 Subscript[Zip, \[Zeta]s][E^Q1 (P/.zrule)]] ];


(* ::Input::Initialization:: *)
U2l={\!\(
\*SubsuperscriptBox[\(B\), \(i_\), \(p_.\)] -> 
\*SuperscriptBox[\(E\), \(\(-p\)\ \[HBar]\ \[Gamma]\ 
\*SubscriptBox[\(b\), \(i\)]\)]\),B^p_.->E^(-p \[HBar] \[Gamma] b), \!\(
\*SubsuperscriptBox[\(T\), \(i_\), \(p_.\)] -> 
\*SuperscriptBox[\(E\), \(p\ \[HBar]\ 
\*SubscriptBox[\(t\), \(i\)]\)]\),T^p_.->E^(p \[HBar] t),\!\(
\*SubsuperscriptBox[\(\[ScriptCapitalA]\), \(i_\), \(p_.\)] -> 
\*SuperscriptBox[\(E\), \(p\ \[Gamma]\ 
\*SubscriptBox[\(\[Alpha]\), \(i\)]\)]\),\[ScriptCapitalA]^p_.->E^(p \[Gamma] \[Alpha])}; 
l2U={E^(c_. Subscript[b, i_]+d_.):>\!\(
\*SubsuperscriptBox[\(B\), \(i\), \(\(-c\)/\((\[HBar]\ \[Gamma])\)\)] 
\*SuperscriptBox[\(E\), \(d\)]\),E^(c_. b+d_.):>B^(-c/(\[HBar] \[Gamma])) E^d,
E^(c_. Subscript[t, i_]+d_.):>\!\(
\*SubsuperscriptBox[\(T\), \(i\), \(c/\[HBar]\)] 
\*SuperscriptBox[\(E\), \(d\)]\),E^(c_. t+d_.):>T^(c/\[HBar]) E^d,
E^(c_. Subscript[\[Alpha], i_]+d_.):>\!\(
\*SubsuperscriptBox[\(\[ScriptCapitalA]\), \(i\), \(c/\[Gamma]\)] 
\*SuperscriptBox[\(E\), \(d\)]\),E^(c_. \[Alpha]+d_.):>\[ScriptCapitalA]^(c/\[Gamma]) E^d,
E^\[ScriptCapitalE]_:>E^Expand@\[ScriptCapitalE]};


(* ::Input::Initialization:: *)
Subscript[LZip, \[Zeta]s_List]@\[DoubleStruckCapitalE][L_,Q_,P_] := Subscript[PP, LZip]@Module[{\[Zeta],z,zs,c,ys,\[Eta]s,lt,zrule,L1,L2,Q1,Q2},
zs=Table[SuperStar[\[Zeta]],{\[Zeta],\[Zeta]s}];
c=L/.Alternatives@@(\[Zeta]s\[Union]zs)->0;
ys=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Zeta]\)]\((L /. Alternatives @@ zs -> 0)\)\),{\[Zeta],\[Zeta]s}];
\[Eta]s=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(z\)]\((L /. Alternatives @@ \[Zeta]s -> 0)\)\),{z,zs}];
lt=Inverse@Table[Subscript[K\[Delta], z,SuperStar[\[Zeta]]]-\!\(
\*SubscriptBox[\(\[PartialD]\), \(z, \[Zeta]\)]L\),{\[Zeta],\[Zeta]s},{z,zs}];
zrule=Thread[zs->lt.(zs+ys)];
L2=(L1=c+\[Eta]s.zs/.zrule)/.Alternatives@@zs->0;
Q2=(Q1=Q/.U2l/.zrule)/.Alternatives@@zs->0;
CF /@ \[DoubleStruckCapitalE][L2,Q2,Det[lt]E^(-L2-Q2) Subscript[Zip, \[Zeta]s][E^(L1+Q1) (P/.U2l/.zrule)]]//.l2U ];


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(B\), \({}\)]\)[L_,R_]:=L R;
\!\(\*SubscriptBox[\(B\), \({is__}\)]\)[L_\[DoubleStruckCapitalE],R_\[DoubleStruckCapitalE]] := Subscript[PP, B]@Module[{n},
Times[
L/.Table[Subscript[(v:b|B|t|T|a|x|y), i]->Subscript[v, n@i],{i,{is}}],
R/.Table[Subscript[(v:\[Beta]|\[Tau]|\[Alpha]|\[ScriptCapitalA]|\[Xi]|\[Eta]), i]->Subscript[v, n@i],{i,{is}}]
] // Subscript[LZip, Join@@Table[{Subscript[\[Beta], n@i],Subscript[\[Tau], n@i],Subscript[a, n@i]},{i,{is}}]] // Subscript[QZip, Join@@Table[{Subscript[\[Xi], n@i],Subscript[y, n@i]},{i,{is}}]] ];
Subscript[B, is___][L_,R_]:=\!\(\*SubscriptBox[\(B\), \({is}\)]\)[L,R];


(* ::Input::Initialization:: *)
SetAttributes[Define, HoldAll];
Define[def_,defs__] := (Define[def]; Define[defs];);
Define[Subscript[op_, is__]=\[ScriptCapitalE]_] := Module[{SD,ii,jj,kk,isp,nis,nisp,sis},Block[{i,j,k},
ReleaseHold[Hold[
SD[Subscript[op, nisp,$k_Integer],Subscript[PP, Boot@$k]@Block[{i,j,k},Subscript[op, isp,$k]=\[ScriptCapitalE];Subscript[op, nis,$k]]];
SD[Subscript[op, isp],\!\(\*SubscriptBox[\(op\), \({is}, $k\)]\)]; SD[Subscript[op, sis__],\!\(\*SubscriptBox[\(op\), \({sis}\)]\)];
]/. {SD->SetDelayed,
isp->{is}/.{i->i_,j->j_,k->k_},
nis->{is}/.{i->ii,j->jj,k->kk},
nisp->{is}/.{i->ii_,j->jj_,k->kk_}
}]  ]]


(* ::Input::Initialization:: *)
$k=2; (*\[HBar]=\[Gamma]=1;*)


(* ::Input::Initialization:: *)
Define[Subscript[am, i,j->k]=Subscript[\[DoubleStruckCapitalE][(Subscript[\[Alpha], i]+Subscript[\[Alpha], j])Subscript[a, k],(E^(-\[Gamma] Subscript[\[Alpha], j]) Subscript[\[Xi], i]+Subscript[\[Xi], j])Subscript[x, k],1], $k],
Subscript[bm, i,j->k]=Subscript[\[DoubleStruckCapitalE][(Subscript[\[Beta], i]+Subscript[\[Beta], j])Subscript[b, k],(Subscript[\[Eta], i]+Subscript[\[Eta], j])Subscript[y, k],E^((E^(- \[Epsilon] Subscript[\[Beta], i])-1)Subscript[\[Eta], j] Subscript[y, k])], $k]]


(* ::Input::Initialization:: *)
Define[Subscript[R, i,j]=Subscript[\[DoubleStruckCapitalE][\[HBar] Subscript[a, j] Subscript[b, i],\[HBar] Subscript[x, j] Subscript[y, i],E^(\!\(
\*UnderoverscriptBox[\(\[Sum]\), \(k = 2\), \($k + 1\)]\ 
\*FractionBox[\(
\*SuperscriptBox[\((1 - 
\*SuperscriptBox[\(E\), \(\[Gamma]\ \[Epsilon]\ \[HBar]\)])\), \(k\)] 
\*SuperscriptBox[\((\[HBar]\ 
\*SubscriptBox[\(y\), \(i\)] 
\*SubscriptBox[\(x\), \(j\)])\), \(k\)]\), \(k \((1 - 
\*SuperscriptBox[\(E\), \(k\ \[Gamma]\ \[Epsilon]\ \[HBar]\)])\)\)]\))], $k],
Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), i,j]=\[DoubleStruckCapitalE][-\[HBar] Subscript[a, j] Subscript[b, i],-\[HBar] Subscript[x, j] Subscript[y, i]/Subscript[B, i],1+If[$k==0, 0,Subscript[(\!\(\*SubscriptBox[
OverscriptBox[\(R\), \(_\)], \({i, j}, $k - 1\)]\)), $k][[3]]-
((Subscript[(\!\(\*SubscriptBox[
OverscriptBox[\(R\), \(_\)], \({i, j}, 0\)]\)), $k] Subscript[R, 1,2] Subscript[(\!\(\*SubscriptBox[
OverscriptBox[\(R\), \(_\)], \({3, 4}, $k - 1\)]\)), $k])~Subscript[B, i,j,1,2]~(Subscript[bm, i,1->i] Subscript[am, j,2->j])~Subscript[B, i,j,3,4]~(Subscript[bm, i,3->i] Subscript[am, j,4->j]))[[3]]]],
Subscript[P, i,j]=\[DoubleStruckCapitalE][Subscript[\[Beta], i]Subscript[\[Alpha], j]/\[HBar],Subscript[\[Eta], i]Subscript[\[Xi], j]/\[HBar],1+If[$k==0,0,Subscript[(\!\(\*SubscriptBox[\(P\), \({i, j}, $k - 1\)]\)), $k][[3]]-
(Subscript[R, 1,2]~Subscript[B, 1,2]~(Subscript[(\!\(\*SubscriptBox[\(P\), \({1, j}, 0\)]\)), $k] Subscript[(\!\(\*SubscriptBox[\(P\), \({i, 2}, $k - 1\)]\)), $k]))[[3]]]]]


(* ::Input::Initialization:: *)
Define[Subscript[aS, j]=Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), i,j]~Subscript[B, i]~Subscript[P, i,j],
Subscript[\!\(\*OverscriptBox[\(aS\), \(_\)]\), i]=\[DoubleStruckCapitalE][-Subscript[a, i] Subscript[\[Alpha], i],-Subscript[x, i] Subscript[\[ScriptCapitalA], i] Subscript[\[Xi], i],1+If[$k==0, 0,Subscript[(\!\(\*SubscriptBox[
OverscriptBox[\(aS\), \(_\)], \({i}, $k - 1\)]\)), $k][[3]]-
(Subscript[(\!\(\*SubscriptBox[
OverscriptBox[\(aS\), \(_\)], \({i}, 0\)]\)), $k]~Subscript[B, i]~Subscript[aS, i]~Subscript[B, i]~Subscript[(\!\(\*SubscriptBox[
OverscriptBox[\(aS\), \(_\)], \({i}, $k - 1\)]\)), $k])[[3]]]]]


(* ::Input::Initialization:: *)
Define[Subscript[bS, i]=Subscript[R, i,1]~Subscript[B, 1]~Subscript[aS, 1]~Subscript[B, 1]~Subscript[P, i,1],
Subscript[\!\(\*OverscriptBox[\(bS\), \(_\)]\), i]=Subscript[R, i,1]~Subscript[B, 1]~Subscript[\!\(\*OverscriptBox[\(aS\), \(_\)]\), 1]~Subscript[B, 1]~Subscript[P, i,1],
Subscript[a\[CapitalDelta], i->j,k]=(Subscript[R, 1,j] Subscript[R, 2,k])~Subscript[B, 1,2]~Subscript[bm, 1,2->3]~Subscript[B, 3]~Subscript[P, 3,i],
Subscript[b\[CapitalDelta], i->j,k]=(Subscript[R, j,1] Subscript[R, k,2])~Subscript[B, 1,2]~Subscript[am, 1,2->3]~Subscript[B, 3]~Subscript[P, i,3]]


(* ::Input::Initialization:: *)
Define[Subscript[dm, i,j->k]=(\[DoubleStruckCapitalE][Subscript[\[Beta], i] Subscript[b, i] + Subscript[\[Alpha], j] Subscript[a, j],Subscript[\[Eta], i] Subscript[y, i]+Subscript[\[Xi], j] Subscript[x, j],1](Subscript[a\[CapitalDelta], i->1,2]~Subscript[B, 2]~Subscript[a\[CapitalDelta], 2->2,3]~Subscript[B, 3]~Subscript[\!\(\*OverscriptBox[\(aS\), \(_\)]\), 3])(Subscript[b\[CapitalDelta], j->-1,-2]~Subscript[B, -2]~Subscript[b\[CapitalDelta], -2->-2,-3]))~Subscript[B, -3,-2,-1,1,2,3,i,j]~(Subscript[P, -1,3] Subscript[P, -3,1] Subscript[am, 2,j->k] Subscript[bm, i,-2->k]),
Subscript[dS, i]=\[DoubleStruckCapitalE][Subscript[\[Beta], i] Subscript[b, 1]+Subscript[\[Alpha], i] Subscript[a, 2],Subscript[\[Eta], i] Subscript[y, 1]+Subscript[\[Xi], i] Subscript[x, 2],1]~Subscript[B, 1,2]~(Subscript[\!\(\*OverscriptBox[\(bS\), \(_\)]\), 1] Subscript[aS, 2])~Subscript[B, 1,2]~Subscript[dm, 2,1->i],
Subscript[d\[CapitalDelta], i->j,k]=(Subscript[b\[CapitalDelta], i->3,1] Subscript[a\[CapitalDelta], i->2,4])~Subscript[B, 1,2,3,4]~(Subscript[dm, 3,4->k] Subscript[dm, 1,2->j])]


(* ::Input::Initialization:: *)
Define[Subscript[C, i]=Subscript[\[DoubleStruckCapitalE][0,0,\!\(
\*SubsuperscriptBox[\(B\), \(i\), \(1/2\)] 
\*SuperscriptBox[\(E\), \(\(-\[HBar]\)\ \[Epsilon]\ 
\*SubscriptBox[\(a\), \(i\)]/2\)]\)], $k],
Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), i]=Subscript[\[DoubleStruckCapitalE][0,0,\!\(
\*SubsuperscriptBox[\(B\), \(i\), \(\(-1\)/2\)] 
\*SuperscriptBox[\(E\), \(\[HBar]\ \[Epsilon]\ 
\*SubscriptBox[\(a\), \(i\)]/2\)]\)], $k],
Subscript[Kink, i] = (Subscript[R, 1,3] Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), 2])~Subscript[B, 1,2]~Subscript[dm, 1,2->1]~Subscript[B, 1,3]~Subscript[dm, 1,3->i],
Subscript[\!\(\*OverscriptBox[\(Kink\), \(_\)]\), i] = (Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), 1,3] Subscript[C, 2])~Subscript[B, 1,2]~Subscript[dm, 1,2->1]~Subscript[B, 1,3]~Subscript[dm, 1,3->i]]


(* ::Input::Initialization:: *)
Define[Subscript[b2t, i]=Subscript[\[DoubleStruckCapitalE][Subscript[\[Alpha], i] Subscript[a, i]-Subscript[\[Beta], i]Subscript[t, i]/\[Gamma],Subscript[\[Xi], i] Subscript[x, i]+Subscript[\[Eta], i] Subscript[y, i],E^(\[Epsilon] Subscript[\[Beta], i]Subscript[a, i]/\[Gamma])], $k],
Subscript[t2b, i]=Subscript[\[DoubleStruckCapitalE][Subscript[\[Alpha], i] Subscript[a, i]-Subscript[\[Tau], i]\[Gamma] Subscript[b, i],Subscript[\[Xi], i] Subscript[x, i]+Subscript[\[Eta], i] Subscript[y, i],E^(\[Epsilon] Subscript[\[Tau], i] Subscript[a, i])], $k]]


(* ::Input::Initialization:: *)
Define[Subscript[kR, i,j]=Subscript[R, i,j]~Subscript[B, i,j]~(Subscript[b2t, i] Subscript[b2t, j]) /. Subscript[t, i|j]->t,
Subscript[\!\(\*OverscriptBox[\(kR\), \(_\)]\), i,j]=Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), i,j]~Subscript[B, i,j]~(Subscript[b2t, i] Subscript[b2t, j]) /. {Subscript[t, i|j]->t,Subscript[T, i|j]->T},
Subscript[km, i,j->k]=(Subscript[t2b, i] Subscript[t2b, j])~Subscript[B, i,j]~Subscript[dm, i,j->k]~Subscript[B, k]~Subscript[b2t, k] /. {Subscript[t, k]->t, Subscript[T, k]->T,Subscript[\[Tau], i|j]->0},
Subscript[kC, i]=Subscript[C, i]~Subscript[B, i]~Subscript[b2t, i] /. Subscript[T, i]->T,
Subscript[\!\(\*OverscriptBox[\(kC\), \(_\)]\), i]=Subscript[\!\(\*OverscriptBox[\(C\), \(_\)]\), i]~Subscript[B, i]~Subscript[b2t, i] /. Subscript[T, i]->T,
Subscript[kKink, i]=Subscript[Kink, i]~Subscript[B, i]~Subscript[b2t, i] /. {Subscript[t, i]->t, Subscript[T, i]->T},
Subscript[\!\(\*OverscriptBox[\(kKink\), \(_\)]\), i]=Subscript[\!\(\*OverscriptBox[\(Kink\), \(_\)]\), i]~Subscript[B, i]~Subscript[b2t, i] /. {Subscript[t, i]->t, Subscript[T, i]->T}]


(* ::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=List@@pd/.x_X:>If[PositiveQ@x,Xp[x[[4]],x[[1]]],Xm[x[[2]],x[[1]]]];
For[k=0,k<2n,++k,
If[k==0\[Or]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]];


(* ::Input::Initialization:: *)
rot[_,0]=\[DoubleStruckCapitalE][0,0,1];
rot[i_,n_]:=Module[{j},
rot[i,n]=If[n>0,rot[i,n-1]Subscript[kC, j],rot[i,n+1]Subscript[\!\(\*OverscriptBox[\(kC\), \(_\)]\), j]]~Subscript[B, i,j]~Subscript[km, i,j->i]];


(* ::Input::Initialization:: *)
Z[K_] := Z[RVK@K];
Z[rvk_RVK] := (*Z[rvk] =*) \!\(\*SubscriptBox[\(PP\), \("\<Z\>"\)]\)@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]=\[DoubleStruckCapitalE][0,0,1];
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, (Subscript[kR, i,j] Subscript[\!\(\*OverscriptBox[\(kKink\), \(_\)]\), k])~Subscript[B, j,k]~Subscript[km, j,k->j],
 Xm, (Subscript[\!\(\*OverscriptBox[\(kR\), \(_\)]\), i,j] Subscript[kKink, k])~Subscript[B, j,k]~Subscript[km, j,k->j]
];
\[Zeta]1=(rot[k,rots[[i]]]\[Zeta]1)~Subscript[B, k,i]~Subscript[km, k,i->i]; rots[[i]]=0;
\[Zeta]1=(\[Zeta]1 rot[k, rots[[i+1]]])~Subscript[B, i,k]~Subscript[km, i,k->i]; rots[[i+1]]=0;
\[Zeta]1=(rot[k,rots[[j]]]\[Zeta]1)~Subscript[B, k,j]~Subscript[km, k,j->j]; rots[[j]]=0;
\[Zeta]1=(\[Zeta]1 rot[k, rots[[j+1]]])~Subscript[B, j,k]~Subscript[km, j,k->j]; rots[[j+1]]=0;
\[Zeta]*=\[Zeta]1;
If[MemberQ[done, i], \[Zeta]=\[Zeta]~Subscript[B, i,i+1]~Subscript[km, i,i+1->i]; st=st/.st[[i+2]]->st[[i+1]]];
If[MemberQ[done, i-1],  \[Zeta]=\[Zeta]~Subscript[B, st[[i]],i]~Subscript[km, st[[i]],i->st[[i]]]; st=st/.st[[i+1]]->st[[i]]]; 
If[MemberQ[done, j],  \[Zeta]=\[Zeta]~Subscript[B, j,j+1]~Subscript[km, j,j+1->j]; st=st/.st[[j+2]]->st[[j+1]]]; 
If[MemberQ[done, j-1],  \[Zeta]=\[Zeta]~Subscript[B, st[[j]],j]~Subscript[km, 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]
];
Simplify/@ (\[Zeta] /. {Subscript[x, 0]->x,Subscript[y, 0]->y,Subscript[a, 0]->a})
]



