Pensieve header: NOE-1 using vcw conventions

SetDirectory["C:\\drorbn\\AcademicPensieve\\2016-11"];
Once[<<KnotTheory`]

NOE-1 Programs

Λ[k_]:=-(((1+(Subscript[t, k])))/4)(4(Subscript[v, k])(Subscript[c, k])(Subscript[w, k])(δ^2)(μ^2)+δ(1+μ)((Subscript[w, k]^2)(α^2)+(Subscript[v, k]^2)(β^2))+(Subscript[v, k]^2)(Subscript[w, k]^2)(δ^3)(1+3μ)+(1-(Subscript[t, k]))(2(((α β+δ μ))^2)-(α^2)(β^2))+2(α β+2δ μ+(Subscript[v, k])(Subscript[w, k])(δ^2)(1+2μ)+2(Subscript[c, k])δ (μ^2))((Subscript[w, k])α+(Subscript[v, k])β)+4((Subscript[c, k])(μ^2)+(Subscript[v, k])(Subscript[w, k])δ(1+μ))(α β+δ μ));

(Subscript[DP, x_->(Subscript[D, α_]),y_->(Subscript[D, β_])])[P_][f_]:= (* means P[(∂_α),(∂_β)][f] *)
Total[CoefficientRules[P,{x,y}]/.({m_,n_}->c_):>c D[f,{α,m},{β,n}]]

CF[𝔼[ω_,L_,Q_,P_]]:=Expand/@Together/@
𝔼[ω/.(Subscript[b, l_]):>Log[(Subscript[t, l])],L,Q/.(Subscript[b, l_]):>Log[(Subscript[t, l])],P/.(Subscript[b, l_]):>Log[(Subscript[t, l])]];
𝔼/:𝔼[ω1_,L1_,Q1_,P1_]𝔼[ω2_,L2_,Q2_,P2_]:=CF@𝔼[ω1 ω2,L1+L2,ω2 Q1+ω1 Q2,((ω2)^4)P1+((ω1)^4)P2];
𝔼 /: 𝔼[ω1_,L1_,Q1_,P1_]≡𝔼[ω2_,L2_,Q2_,P2_] := (ω1==ω2∧L1==L2∧Q1==Q2∧P1==P2);

(Subscript[N, (Subscript[c, j_])(Subscript[(x:v|w), i_])->k_])[𝔼[ω_,L_,Q_,P_]]:=With[{q=(E^γ)β (Subscript[x, k])+γ (Subscript[c, k])},CF[
𝔼[ω,γ (Subscript[c, k])+(L/.(Subscript[c, j])->0),ω (E^γ)β (Subscript[x, k])+(Q/.(Subscript[x, i])->0),(E^(-q))(Subscript[DP, (Subscript[c, j])->(Subscript[D, γ]),(Subscript[x, i])->(Subscript[D, β])])[P][(E^q)]]/.{γ->(∂_(Subscript[c, j]))L,β->(ω^(-1))(∂_(Subscript[x, i]))Q}]];

(Subscript[N, (Subscript[w, i_])(Subscript[v, j_])->k_])[𝔼[ω_,L_,Q_,P_]]:=With[{q=((1-(Subscript[t, k]))α β+β (Subscript[v, k])+δ (Subscript[v, k])(Subscript[w, k])+α (Subscript[w, k]))/μ},CF[
𝔼[μ ω,L,μ ω q+μ(Q/.(Subscript[w, i])|(Subscript[v, j])->0),(μ^4)(E^(-q))(Subscript[DP, (Subscript[w, i])->(Subscript[D, α]),(Subscript[v, j])->(Subscript[D, β])])[P][(E^q)]+(ω^4)Λ[k]]/.μ->1+((Subscript[t, k])-1)δ/.{α->(ω^(-1))((∂_(Subscript[w, i]))Q/.(Subscript[v, j])->0),β->(ω^(-1))((∂_(Subscript[v, j]))Q/.(Subscript[w, i])->0),δ->(ω^(-1))(∂_((Subscript[w, i]),(Subscript[v, j])))Q}]];

(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]

(Subscript[R, i_,j_]^(+)):=𝔼[1,(Subscript[b, i])(Subscript[c, j]),(Subscript[v, i])(Subscript[w, j]),(Subscript[v, i])(Subscript[c, i])(Subscript[w, j])+(Subscript[c, i])(Subscript[c, j])+(Subscript[v, i]^2)(Subscript[w, j]^2)/4];
(Subscript[R, i_,j_]^(-)):=𝔼[1,-(Subscript[b, i])(Subscript[c, j]),-(Subscript[t, i]^(-1))(Subscript[v, i])(Subscript[w, j]),-(Subscript[c, i])(Subscript[c, j])+(Subscript[t, i]^(-1))(Subscript[v, i])(Subscript[c, j])(Subscript[w, j])-(Subscript[t, i]^(-2))(Subscript[v, i]^2)(Subscript[w, j]^2)/4];
(Subscript[ur, i_]):=𝔼[(Subscript[t, i]^(-1/2)),0,0,(Subscript[c, i])(Subscript[t, i]^(-2))];(Subscript[nr, i_]):=𝔼[(Subscript[t, i]^(1/2)),0,0,-(Subscript[c, i])(Subscript[t, i]^2)];
(Subscript[ul, _])=(Subscript[nl, _]) = 𝔼[1,0,0,0];

The Trefoil

z2=(Subscript[R, 1,11]^(+))(Subscript[R, 4,2]^(-))(Subscript[nr, 3])(Subscript[R, 15,5]^(+))(Subscript[R, 6,8]^(-))(Subscript[ur, 7])(Subscript[R, 9,16]^(+))(Subscript[nr, 10])(Subscript[R, 12,14]^(-))(Subscript[ur, 13]);
Do[z2=z2//(Subscript[m, 1,k->1]), {k,2,16}];z2=z2 /. (Subscript[a_, 1]):>a

Meta-Associativity

Q0=𝔼[1,Sum[(Subscript[l, i,j])(Subscript[b, i])(Subscript[c, j]),{i,3},{j,3}],Sum[(Subscript[a, i,j])(Subscript[v, i])(Subscript[w, j]),{i,3},{j,3}],0]
t1=Q0 // (Subscript[m, 1,2->4])//(Subscript[m, 4,3->5])
t2=Q0 // (Subscript[m, 2,3->4])//(Subscript[m, 1,4->5])
t3=(t1≡t2)

Computing (Subscript[Z, 1])

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]];

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])];

{rot[i,2], rot[i,-2]}

Z[K_] := Z[RVK@K];
Z[rvk_RVK] := Z[rvk] = 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[v, 0])->v,(Subscript[c, 0])->c,(Subscript[w, 0])->w}
]

Z[Knot[3,1]]

(Subscript[t, _])=t;  Z[Knot["K11n34"]//Mirror]

(Subscript[t, _])=t;  Z[Knot["K11n42"]//Mirror]

Dynamic[$now]

(Subscript[t, _])=t; tab7=Table[$now=(K->Timing@Z[K]), {K, AllKnots[{3,10}]}];

Extracting (Subscript[ρ, 1])

za[K_Knot] := Z[K][[1]];
zp[K_Knot] := Z[K][[4]];

Union@Table[za[K]==Alexander[K][t], {K, AllKnots[{3,7}]}]

MatrixForm@Table[{za[K], Factor@((Coefficient[zp[K],c])/(-2t ((za[K])^3)D[za[K],t])), Factor@((Coefficient[zp[K],v w])/(2(t/(1-t))((za[K])^3)D[za[K],t]))}, {K, AllKnots[{3,7}]}]

etab=Get["../Talks/UNC-1610/etab.m"];
e[K_]:= K/. etab;

MatrixForm@(mat=Table[{(*(Subscript[K[[1]], K[[2]]]),za[K],*) Expand@Together@((((zp[K] /. v|c|w->0))/((za[K])^2))), Expand@(za[K]D[za[K],t]),e[K]}, {K, AllKnots[{3,7}]}])

MatrixRank[mat]

NullSpace[mat]

(Subscript[ρ, 1])[K_] :=Expand@Together[-((t(zp[K] /. v|c|w->0))/((((-1+t))^2)((za[K])^2)))+(((t^2)za[K]D[za[K],t])/(((-1+t))^2))]

Union@Table[Simplify[
zp[K]==((((za[K])^2) ((((t-1))^3) (Subscript[ρ, 1])[K]+(t^2) (1-t-2 c (1-t)+2 v w) za[K] D[za[K],t]))/((1-t) t))
], {K, AllKnots[{3,10}]}]

Union@Table[e[K]==(Subscript[ρ, 1])[K], {K, AllKnots[{3,10}]}]