(* ::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:: *)
Quiet@Once[<<KnotTheory`];


(* ::Input::Initialization:: *)
CCF[\[ScriptCapitalE]_] := ExpandDenominator@ExpandNumerator@Together[
Expand[\[ScriptCapitalE]] //. E^x_ E^y_:>E^(x+y) /. E^x_:>E^CCF[x]];
CF[\[ScriptCapitalE]_List]:=CF/@\[ScriptCapitalE];
CF[sd_SeriesData] := MapAt[CF,sd,3];
CF[\[ScriptCapitalE]_] := Module[
{vs=Cases[\[ScriptCapitalE],Subscript[(x|\[Xi]), _],\[Infinity]]\[Union]{x,\[Xi]}},
Total[CoefficientRules[Expand[\[ScriptCapitalE]], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))]
];
CF[\[ScriptCapitalE]_\[DoubleStruckCapitalE]]:=CF/@\[ScriptCapitalE]; CF[Subscript[\[DoubleStruckCapitalE], sp___][\[ScriptCapitalE]s___]]:=CF/@Subscript[\[DoubleStruckCapitalE], sp][\[ScriptCapitalE]s];


(* ::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];


(* ::Input::Initialization:: *)
SuperStar[x]=\[Xi];SuperStar[\[Xi]]=x; SuperStar[(Subscript[u_, i_])]:=Subscript[(SuperStar[u]), i];


(* ::Input::Initialization:: *)
Subscript[D, v_][f_]:=\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]f\); \!\(\*SubscriptBox[\(D\), \({v_, 0}\)]\)[f_]:=f; \!\(\*SubscriptBox[\(D\), \({}\)]\)[f_]:=f; \!\(\*SubscriptBox[\(D\), \({v_, n_Integer}\)]\)[f_]:=Subscript[D, v][\!\(\*SubscriptBox[\(D\), \({v, n - 1}\)]\)[f]];
\!\(\*SubscriptBox[\(D\), \({l_List, ls___}\)]\)[f_]:=\!\(\*SubscriptBox[\(D\), \({ls}\)]\)[Subscript[D, l][f]];


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


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


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(B\), \({}\)]\)[L_,R_]:=L R;
\!\(\*SubscriptBox[\(B\), \({is__}\)]\)[L_\[DoubleStruckCapitalE],R_\[DoubleStruckCapitalE]] := Module[{n},
Times[
L/.Table[Subscript[x, i]->Subscript[x, n@i],{i,{is}}],
R/.Table[Subscript[\[Xi], i]->Subscript[\[Xi], n@i],{i,{is}}]
]  // Subscript[QZip, Join@@Table[{Subscript[\[Xi], n@i]},{i,{is}}]] ];
Subscript[B, is___][L_,R_]:=\!\(\*SubscriptBox[\(B\), \({is}\)]\)[L,R];


(* ::Input::Initialization:: *)
Subscript[B, is_List][Subscript[\[DoubleStruckCapitalE], d1_->r1_][L1_,Q1_,P1_],Subscript[\[DoubleStruckCapitalE], d2_->r2_][L2_,Q2_,P2_]]:=Subscript[\[DoubleStruckCapitalE], (d1\[Union]Complement[d2,is])->(r2\[Union]Complement[r1,is])]@@Subscript[B, is][\[DoubleStruckCapitalE][L1,Q1,P1],\[DoubleStruckCapitalE][L2,Q2,P2]];
Subscript[\[DoubleStruckCapitalE], d1_->r1_][L1_,Q1_,P1_]//Subscript[\[DoubleStruckCapitalE], d2_->r2_][L2_,Q2_,P2_] := Subscript[B, r1\[Intersection]d2][Subscript[\[DoubleStruckCapitalE], d1->r1][L1,Q1,P1],Subscript[\[DoubleStruckCapitalE], d2->r2][L2,Q2,P2]];
Subscript[\[DoubleStruckCapitalE], d1_->r1_][L1_,Q1_,P1_]\[Congruent]Subscript[\[DoubleStruckCapitalE], d2_->r2_][L2_,Q2_,P2_] ^:= (d1==d2)\[And](r1==r2)\[And](\[DoubleStruckCapitalE][L1,Q1,P1]\[Congruent]\[DoubleStruckCapitalE][L2,Q2,P2]);
Subscript[\[DoubleStruckCapitalE], d1_->r1_][L1_,Q1_,P1_]Subscript[\[DoubleStruckCapitalE], d2_->r2_][L2_,Q2_,P2_] ^:= Subscript[\[DoubleStruckCapitalE], (d1\[Union]d2)->(r1\[Union]r2)]@@(\[DoubleStruckCapitalE][L1,Q1,P1]\[DoubleStruckCapitalE][L2,Q2,P2]);
Subscript[\[DoubleStruckCapitalE], _][\[ScriptCapitalE]___][i_]:={\[ScriptCapitalE]}[[i]];


(* ::Input::Initialization:: *)
$k=0;
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],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:: *)
$n=1; Define[
Subscript[nI, i]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i} \[Rule] {i}\)]\)[0,Subscript[\[Xi], i] Subscript[x, i],1],
Subscript[nm, i,j->k]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i, j} \[Rule] {k}\)]\)[0,(Subscript[\[Xi], i]+Subscript[\[Xi], j])Subscript[x, k],1],
Subscript[n\[Tau], i,j]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i, j} \[Rule] {i, j}\)]\)[0,Subscript[\[Xi], i] Subscript[x, i]+Subscript[\[Xi], j] Subscript[x, j],1+\[HBar] Subscript[\[Xi], i] Subscript[x, i] Subscript[\[Xi], j] Subscript[x, j]+O[\[HBar]]^2],
Subscript[\!\(\*OverscriptBox[\(n\[Tau]\), \(_\)]\), i,j]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i, j} \[Rule] {i, j}\)]\)[0,Subscript[\[Xi], i] Subscript[x, i]+Subscript[\[Xi], j] Subscript[x, j],1-\[HBar] Subscript[\[Xi], i] Subscript[x, i] Subscript[\[Xi], j] Subscript[x, j]+O[\[HBar]]^2](**),
Subscript[nS, i]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i} \[Rule] {i}\)]\)[0,-Subscript[\[Xi], i] Subscript[x, i],1+\[HBar] (Subscript[\[Xi], i]^2 Subscript[x, i]^2)/2+O[\[HBar]]^2],
Subscript[\!\(\*OverscriptBox[\(nS\), \(_\)]\), i]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i} \[Rule] {i}\)]\)[0,-Subscript[\[Xi], i] Subscript[x, i],1-\[HBar] (Subscript[\[Xi], i]^2 Subscript[x, i]^2)/2+O[\[HBar]]^2],
Subscript[n\[CapitalDelta], i->j,k]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i} \[Rule] {j, k}\)]\)[0,(Subscript[x, j]+Subscript[x, k])Subscript[\[Xi], i],1+\[HBar] (Subscript[\[Xi], i]^2 Subscript[x, j] Subscript[x, k])/2+O[\[HBar]]^2],
Subscript[n\[Phi], i]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i} \[Rule] {i}\)]\)[0,T Subscript[\[Xi], i] Subscript[x, i],1],
Subscript[\!\(\*OverscriptBox[\(n\[Phi]\), \(_\)]\), i]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i} \[Rule] {i}\)]\)[0,T^-1 Subscript[\[Xi], i] Subscript[x, i],1],
Subscript[n\[Delta], i->j,k]=Subscript[n\[CapitalDelta], i->1,2]//Subscript[n\[CapitalDelta], 2->k,3]//Subscript[nS, 3]//Subscript[n\[Phi], 3]//Subscript[n\[Tau], k,3]//Subscript[nm, 1,3->j],
Subscript[nR, i,j]=Subscript[n\[Phi], j]//Subscript[n\[Delta], i->1,i]//Subscript[n\[Tau], i,j]//Subscript[nm, 1,j->j],
Subscript[\!\(\*OverscriptBox[\(nR\), \(_\)]\), i,j]=Subscript[n\[Delta], i->z1,i]//Subscript[\!\(\*OverscriptBox[\(n\[Tau]\), \(_\)]\), z1,j]//Subscript[\!\(\*OverscriptBox[\(nS\), \(_\)]\), z1]//Subscript[\!\(\*OverscriptBox[\(n\[Tau]\), \(_\)]\), i,j]//Subscript[\!\(\*OverscriptBox[\(n\[Tau]\), \(_\)]\), i,z1]//Subscript[nm, z1,j->j]//Subscript[\!\(\*OverscriptBox[\(n\[Phi]\), \(_\)]\), j],
Subscript[nC, i]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i} \[Rule] {i}\)]\)[0,Subscript[\[Xi], i] Subscript[x, i],1+ Subscript[\[Xi], i] Subscript[x, i] \[HBar]+O[\[HBar]]^2],Subscript[\!\(\*OverscriptBox[\(nC\), \(_\)]\), i]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i} \[Rule] {i}\)]\)[0,Subscript[\[Xi], i] Subscript[x, i],1-Subscript[\[Xi], i] Subscript[x, i] \[HBar]+O[\[HBar]]^2],
Subscript[nKinkr, i]=(Subscript[nR, 1,3] Subscript[\!\(\*OverscriptBox[\(nC\), \(_\)]\), 2]//Subscript[n\[Mu], 1,2->1]//Subscript[n\[Mu], 1,3->i]),
Subscript[nKinkl, i]=(Subscript[nR, 3,1] Subscript[nC, 2]//Subscript[n\[Mu], 1,2->1]//Subscript[n\[Mu], 1,3->i]),
Subscript[\!\(\*OverscriptBox[\(nKinkr\), \(_\)]\), i]=(Subscript[\!\(\*OverscriptBox[\(nR\), \(_\)]\), 3,1] Subscript[\!\(\*OverscriptBox[\(nC\), \(_\)]\), 2]//Subscript[n\[Mu], 1,2->1]//Subscript[n\[Mu], 1,3->i]),
Subscript[\!\(\*OverscriptBox[\(nKinkl\), \(_\)]\), i]=(Subscript[\!\(\*OverscriptBox[\(nR\), \(_\)]\), 1,3] Subscript[nC, 2]//Subscript[n\[Mu], 1,2->1]//Subscript[n\[Mu], 1,3->i]) ]


(* ::Input::Initialization:: *)
(*For composing tensors, leg by leg*)
Subscript[n\[Mu], i_,j_->k_][Subscript[\[DoubleStruckCapitalE], d_->r_][0,Q_,P_]]:=Module[{v},
\!\(\*SubscriptBox[\(QZip\), \({
\*SubscriptBox[\(\[Xi]\), \(v\)]}\)]\)[\[DoubleStruckCapitalE][0,Q/.{Subscript[\[Xi], j]->Subscript[\[Xi], v],Subscript[x, i]->Subscript[x, v],Subscript[\[Xi], i]->Subscript[\[Xi], k],Subscript[x, j]->Subscript[x, k]},P/.{Subscript[\[Xi], j]->Subscript[\[Xi], v],Subscript[x, i]->Subscript[x, v],Subscript[\[Xi], i]->Subscript[\[Xi], k],Subscript[x, j]->Subscript[x, k]}]]
]/.\[DoubleStruckCapitalE]->Subscript[\[DoubleStruckCapitalE], (d/.{i->Nothing,j->k})->(r/.{i->Nothing,j->k})]


(* ::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:: *)
rot[i_,0]:=Subscript[nI, 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[nC, j],rot[i,n+1]Subscript[\!\(\*OverscriptBox[\(nC\), \(_\)]\), j]]//Subscript[n\[Mu], 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@ThinPosition[K,100]];
Z[rvk_RVK] := Monitor[ Module[{\[Zeta],done,st,c, \[Chi],i,j,k,totrot=Total[rvk[[2]]]},
\[Zeta]=1; done={}; st=Range[2Length[rvk[[1]]]]; $M={};
Do[AppendTo[$M,c];
{i,j}=List@@c;
If[Head[c]===Xp,If[totrot<=0,totrot++;\[Chi]=Subscript[\!\(\*OverscriptBox[\(nKinkl\), \(_\)]\), 0] Subscript[nR, i,j]//Subscript[n\[Mu], j,0->j],totrot--;\[Chi]=Subscript[\!\(\*OverscriptBox[\(nKinkr\), \(_\)]\), 0] Subscript[nR, i,j]//Subscript[n\[Mu], j,0->j]] ,
If[totrot<=0,totrot++;\[Chi]=Subscript[nKinkl, 0] Subscript[\!\(\*OverscriptBox[\(nR\), \(_\)]\), i,j]//Subscript[n\[Mu], j,0->j],totrot--;\[Chi]=Subscript[nKinkr, 0] Subscript[\!\(\*OverscriptBox[\(nR\), \(_\)]\), i,j]//Subscript[n\[Mu], j,0->j]] 
 ];
Do[\[Chi]=(rot[0,rvk[[2,k]]]\[Chi])//Subscript[n\[Mu], 0,k->k], {k,{i,j}}];
\[Zeta]*=\[Chi];
Do[
If[MemberQ[done, k+1],\[Zeta]=\[Zeta]//Subscript[n\[Mu], k,k+1->k]; st=st/.k+1->k];
If[MemberQ[done, k-1],\[Zeta]=\[Zeta]//Subscript[n\[Mu], 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] 
], {Length@$M,$M}]
aTerm[K_]:=T D[Alexander[K][T],T]/(Alexander[K][T])^2
Subscript[\[Rho], 1][K_]:=Module[{z=Z[K][[3]],Al},Al=1/(z/.\[HBar]->0);(-T Al^3)/(T-1)^2 (Coefficient[z,\[HBar]]-T D[Al,T]/Al^2)]//Factor



