Pensieve header: Optimizing the 1-smidgen program using my 1994 Profile.m.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2016-09"];
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]];

NOE-1t

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

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

CF[𝔼[ω_,L_,Q_,P_]] := Profile[CF,
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];

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

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

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

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

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

Z

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

Timing[Z[Knot[10,100]]]

BeginProfile[];
Timing[Z[Knot[10,100]]]
EndProfile[];

PrintProfile[]