(* ::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:: *)
SetDirectory["C:\\drorbn\\AcademicPensieve\\2016-11"];
Once[<<KnotTheory`]


(* ::Input::Initialization:: *)
\[CapitalLambda][k_]:=-((\[Lambda](1+Subscript[t, k]))/4)(4Subscript[v, k] Subscript[c, k] Subscript[w, k] \[Delta]^2 \[Mu]^2+\[Delta](1+\[Mu])(\!\(
\*SubsuperscriptBox[\(w\), \(k\), \(2\)] 
\*SuperscriptBox[\(\[Alpha]\), \(2\)]\)+\!\(
\*SubsuperscriptBox[\(v\), \(k\), \(2\)] 
\*SuperscriptBox[\(\[Beta]\), \(2\)]\))+\!\(
\*SubsuperscriptBox[\(v\), \(k\), \(2\)] 
\*SubsuperscriptBox[\(w\), \(k\), \(2\)] 
\*SuperscriptBox[\(\[Delta]\), \(3\)] \((1 + 3  \[Mu])\)\)+(1-Subscript[t, k])(2(\[Alpha] \[Beta]+\[Delta] \[Mu])^2-\[Alpha]^2 \[Beta]^2)+2(\[Alpha] \[Beta]+2\[Delta] \[Mu]+Subscript[v, k] Subscript[w, k] \[Delta]^2 (1+2\[Mu])+2Subscript[c, k]\[Delta] \[Mu]^2)(Subscript[w, k]\[Alpha]+Subscript[v, k]\[Beta])+4(Subscript[c, k] \[Mu]^2+Subscript[v, k] Subscript[w, k]\[Delta](1+\[Mu]))(\[Alpha] \[Beta]+\[Delta] \[Mu]));


(* ::Input::Initialization:: *)
Subscript[DP, x_->Subscript[D, \[Alpha]_],y_->Subscript[D, \[Beta]_]][P_][f_]:= (* means P[\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Alpha]\)]\(\(,\)
\*SubscriptBox[\(\[PartialD]\), \(\[Beta]\)]\)\)][f] *)
Total[CoefficientRules[P,{x,y}]/.({m_,n_}->c_):>c D[f,{\[Alpha],m},{\[Beta],n}]]


(* ::Input::Initialization:: *)
CF[\[DoubleStruckCapitalE][\[Omega]_,L_,Q_,P_]]:=Expand/@Together/@
\[DoubleStruckCapitalE][\[Omega]/.Subscript[b, l_]:>Log[Subscript[t, l]],L,Q/.Subscript[b, l_]:>Log[Subscript[t, l]],P/.Subscript[b, l_]:>Log[Subscript[t, l]]];
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][\[Omega]1_,L1_,Q1_,P1_]\[DoubleStruckCapitalE][\[Omega]2_,L2_,Q2_,P2_]:=CF@\[DoubleStruckCapitalE][\[Omega]1 \[Omega]2,L1+L2,\[Omega]2 Q1+\[Omega]1 Q2,\[Omega]2^4 P1+\[Omega]1^4 P2];
\[DoubleStruckCapitalE] /: \[DoubleStruckCapitalE][\[Omega]1_,L1_,Q1_,P1_]\[Congruent]\[DoubleStruckCapitalE][\[Omega]2_,L2_,Q2_,P2_] := (\[Omega]1==\[Omega]2\[And]L1==L2\[And]Q1==Q2\[And]P1==P2);


(* ::Input::Initialization:: *)
Subscript[N, Subscript[c, j_] Subscript[(x:v|w), i_]->k_][\[DoubleStruckCapitalE][\[Omega]_,L_,Q_,P_]]:=With[{q=E^\[Gamma] \[Beta] Subscript[x, k]+\[Gamma] Subscript[c, k]},CF[
\[DoubleStruckCapitalE][\[Omega],\[Gamma] Subscript[c, k]+(L/.Subscript[c, j]->0),\[Omega] E^\[Gamma] \[Beta] Subscript[x, k]+(Q/.Subscript[x, i]->0),E^-q Subscript[DP, Subscript[c, j]->Subscript[D, \[Gamma]],Subscript[x, i]->Subscript[D, \[Beta]]][P][E^q]]/.{\[Gamma]->\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(c\), \(j\)]]L\),\[Beta]->\[Omega]^-1 \!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(x\), \(i\)]]Q\)}]];


(* ::Input::Initialization:: *)
Subscript[N, Subscript[w, i_] Subscript[v, j_]->k_][\[DoubleStruckCapitalE][\[Omega]_,L_,Q_,P_]]:=With[{q=((1-Subscript[t, k])\[Alpha] \[Beta]+\[Beta] Subscript[v, k]+\[Delta] Subscript[v, k] Subscript[w, k]+\[Alpha] Subscript[w, k])/\[Mu]},CF[
\[DoubleStruckCapitalE][\[Mu] \[Omega],L,\[Mu] \[Omega] q+\[Mu](Q/.Subscript[w, i]|Subscript[v, j]->0),\[Mu]^4 E^-q Subscript[DP, Subscript[w, i]->Subscript[D, \[Alpha]],Subscript[v, j]->Subscript[D, \[Beta]]][P][E^q]+\[Omega]^4 \[CapitalLambda][k]]/.\[Mu]->1+(Subscript[t, k]-1)\[Delta]/.{\[Alpha]->\[Omega]^-1 (\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(w\), \(i\)]]Q\)/.Subscript[v, j]->0),\[Beta]->\[Omega]^-1 (\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(v\), \(j\)]]Q\)/.Subscript[w, i]->0),\[Delta]->\[Omega]^-1 \!\(
\*SubscriptBox[\(\[PartialD]\), \(
\*SubscriptBox[\(w\), \(i\)], 
\*SubscriptBox[\(v\), \(j\)]\)]Q\)}]];


(* ::Input::Initialization:: *)
Subscript[m, i_,j_->k_][Z_]:=Module[{x,z},
Z//Subscript[N, Subscript[w, i] Subscript[v, j]->x]//Subscript[N, Subscript[c, i] Subscript[v, x]->x]//Subscript[N, Subscript[w, x] Subscript[c, j]->x]//ReplaceAll[Subscript[z_, i|j|x]->Subscript[z, k]]//CF]


(* ::Input::Initialization:: *)
\!\(
\*SubsuperscriptBox[\(R\), \(i_, j_\), \(+\)] := \(\[DoubleStruckCapitalE][1, 
\*SubscriptBox[\(b\), \(i\)] 
\*SubscriptBox[\(c\), \(j\)], 
\*SubscriptBox[\(v\), \(i\)] 
\*SubscriptBox[\(w\), \(j\)], 
\*SubscriptBox[\(v\), \(i\)] 
\*SubscriptBox[\(c\), \(i\)] 
\*SubscriptBox[\(w\), \(j\)] + 
\*SubscriptBox[\(c\), \(i\)] 
\*SubscriptBox[\(c\), \(j\)] + 
\*SubsuperscriptBox[\(v\), \(i\), \(2\)] 
\*SubsuperscriptBox[\(w\), \(j\), \(2\)]/4]\)\);
\!\(
\*SubsuperscriptBox[\(R\), \(i_, j_\), \(-\)] := \(\[DoubleStruckCapitalE][1, \(-
\*SubscriptBox[\(b\), \(i\)]\) 
\*SubscriptBox[\(c\), \(j\)], \(-
\*SubsuperscriptBox[\(t\), \(i\), \(-1\)]\) 
\*SubscriptBox[\(v\), \(i\)] 
\*SubscriptBox[\(w\), \(j\)], \(-
\*SubscriptBox[\(c\), \(i\)]\) 
\*SubscriptBox[\(c\), \(j\)] + 
\*SubsuperscriptBox[\(t\), \(i\), \(-1\)] 
\*SubscriptBox[\(v\), \(i\)] 
\*SubscriptBox[\(c\), \(j\)] 
\*SubscriptBox[\(w\), \(j\)] - 
\*SubsuperscriptBox[\(t\), \(i\), \(-2\)] 
\*SubsuperscriptBox[\(v\), \(i\), \(2\)] 
\*SubsuperscriptBox[\(w\), \(j\), \(2\)]/4]\)\);
Subscript[ur, i_]:=\[DoubleStruckCapitalE][\!\(
\*SubsuperscriptBox[\(t\), \(i\), \(\(-1\)/2\)], 0, 0, \(
\*SubscriptBox[\(c\), \(i\)] 
\*SubsuperscriptBox[\(t\), \(i\), \(-2\)]\)\)];Subscript[nr, i_]:=\[DoubleStruckCapitalE][\!\(
\*SubsuperscriptBox[\(t\), \(i\), \(1/2\)], 0, 0, \(\(-
\*SubscriptBox[\(c\), \(i\)]\) 
\*SubsuperscriptBox[\(t\), \(i\), \(2\)]\)\)];
Subscript[ul, _]=Subscript[nl, _] = \[DoubleStruckCapitalE][1,0,0,0];


(* ::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.";
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\[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][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]];


(* ::Input::Initialization:: *)
trZ[K_] := trZ[RVK@K];
trZ[rvk_RVK] := Module[{tr,todo,n,rots,\[Zeta],done,st,x, \[Zeta]1, i,j,k,k1,k2,k3},
{todo,rots}=List@@rvk;
AppendTo[rots,0];
n=Length[todo];
tr={\[Zeta]=\[DoubleStruckCapitalE][1,0,0,0]};
done={0};
st=Range[0,2n+1];
While[todo=!={},
{x}=MaximalBy[todo, Length[done\[Intersection]{#[[1]], #[[2]], #[[1]]-1,#[[2]]-1}]&,1];
Z$todo=todo; Z$x=x;
{i,j}=List@@x;
\[Zeta]1=Switch[Head[x],
 Xp, Subscript[m, j,k->j][\!\(
\*SubsuperscriptBox[\(R\), \(i, j\), \(+\)] \((\(\(
\*SubsuperscriptBox[\(R\), \(k3, k\), \(-\)] 
\*SubscriptBox[\(nr\), \(k1\)] 
\*SubscriptBox[\(ul\), \(k2\)] // 
\*SubscriptBox[\(m\), \(k, k1 -> k\)]\) // 
\*SubscriptBox[\(m\), \(k, k2 -> k\)]\) // 
\*SubscriptBox[\(m\), \(k, k3 -> k\)])\)\)],
 Xm, Subscript[m, j,k->j][\!\(
\*SubsuperscriptBox[\(R\), \(i, j\), \(-\)] \((\(\(
\*SubsuperscriptBox[\(R\), \(k, k3\), \(+\)] 
\*SubscriptBox[\(nr\), \(k1\)] 
\*SubscriptBox[\(ul\), \(k2\)] // 
\*SubscriptBox[\(m\), \(k, k1 -> k\)]\) // 
\*SubscriptBox[\(m\), \(k, k2 -> k\)]\) // 
\*SubscriptBox[\(m\), \(k, k3 -> k\)])\)\)]
];
\[Zeta]1=rot[k,rots[[i]]]\[Zeta]1 // Subscript[m, k,i->i]; rots[[i]]=0;
\[Zeta]1=\[Zeta]1 rot[k, rots[[i+1]]] // Subscript[m, i,k->i]; rots[[i+1]]=0;
\[Zeta]1=rot[k,rots[[j]]]\[Zeta]1 // Subscript[m, k,j->j]; rots[[j]]=0;
\[Zeta]1=\[Zeta]1 rot[k, rots[[j+1]]] // Subscript[m, j,k->j]; rots[[j+1]]=0;
\[Zeta]*=\[Zeta]1;
If[MemberQ[done, i],  \[Zeta]=\[Zeta]//Subscript[m, i,i+1->i]; st=st/.st[[i+2]]->st[[i+1]]];
If[MemberQ[done, i-1],  \[Zeta]=\[Zeta]//Subscript[m, st[[i]],i->st[[i]]]; st=st/.st[[i+1]]->st[[i]]]; 
If[MemberQ[done, j],  \[Zeta]=\[Zeta]//Subscript[m, j,j+1->j]; st=st/.st[[j+2]]->st[[j+1]]]; 
If[MemberQ[done, j-1],  \[Zeta]=\[Zeta]//Subscript[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, x];
AppendTo[tr, \[Zeta]];
];
tr
]



