Pensieve header: A Perturbed Alexander Invariant, with formulas from PABI-InBack.nb.

Programs

Once[<<KnotTheory`];

PD[GST48]=PD[X[1,15,2,14],X[29,2,30,3],X[40,4,41,3],X[4,44,5,43],X[5,26,6,27],X[95,7,96,6],X[7,1,8,96],X[8,14,9,13],X[28,9,29,10],X[41,11,42,10],X[11,43,12,42],X[12,27,13,28],X[15,31,16,30],X[61,16,62,17],X[72,17,73,18],X[83,18,84,19],X[34,20,35,19],X[20,89,21,90],X[92,21,93,22],X[22,79,23,80],X[23,68,24,69],X[24,57,25,58],X[56,25,57,26],X[31,63,32,62],X[32,74,33,73],X[33,85,34,84],X[35,50,36,51],X[81,37,82,36],X[70,38,71,37],X[59,39,60,38],X[54,39,55,40],X[55,45,56,44],X[45,59,46,58],X[46,70,47,69],X[47,81,48,80],X[91,49,92,48],X[49,91,50,90],X[82,52,83,51],X[71,53,72,52],X[60,54,61,53],X[74,63,75,64],X[85,64,86,65],X[65,76,66,77],X[66,87,67,88],X[94,67,95,68],X[86,75,87,76],X[77,88,78,89],X[93,78,94,79]];

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={1},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=1,k<=2n,++k,
If[FreeQ[front,-k],
front=Flatten@Replace[front,k->(xs/.{
Xp[k,l_]|Xm[l_,k]:>{l+1,k+1,-l},
Xp[l_,k]|Xm[k,l_]:>(++rots[[l]];{-l,k+1,l+1}),
_Xp|_Xm:>{}
}), {1}],
Cases[front,k|-k]/.{k,-k}:>--rots[[k]];
]
];
RVK[xs,rots] ];
RVK[K_]:=RVK[PD[K]];

Fast (Subscript[ρ, 1])

OldPAI[K_]:=Module[{Cs,Rs,n,B,A,c,s,i,j,Δ,G,g,p1},
{Cs,Rs}=List@@RVK[K]; n=Length[Cs];
B=Table[0,2n,2n+1];
Do[s=If[Head[c]===Xp,1,-1]; {i,j}=List@@c;
B[[{i,j},{i,i+1,j,j+1}]]=(({{1, -1, 0, 0}, {0, (T^s)-1, 1, -(T^s)}})),
{c,Cs}];
Δ=Det[A=B[[All,2;;]]];
G=Prepend[Table[0,2n]][Inverse[A]]; (Subscript[g, α_,β_]):=G[[α,β]];
p1=Plus[
Sum[s=If[Head[c]===Xp,1,-1]; {i,j}=List@@c; Δ*=(T^(-s/2));
s(2(Subscript[g, i,i])(Subscript[g, i,j])-(Subscript[g, i,i])(Subscript[g, j,j])-(Subscript[g, i,j])(Subscript[g, j,i])+(1-(T^s))((Subscript[g, i,j]^2)-(Subscript[g, i,j])(Subscript[g, j,j]))),{c,Cs}],
Sum[Δ*=(T^(Rs[[k]]/2)); Rs[[k]](Subscript[g, k,k]),{k,2n}] ];
Factor@{Δ,T(((Δ^2)p1-T Δ(∂_T)Δ)/(((T-1))^2))} ];

PAI[K_]:=Module[{Cs,r,n,B,A,c,s,i,j,Δ,G,g,p1},
{Cs,r}=List@@RVK[K] /. {Xp[i_,j_]:>{+1,i,j},Xm[i_,j_]:>{-1,i,j}};
n=Length[Cs];
B=Table[0,2n,2n+1];
Do[{s,i,j}=c;B[[{i,j},{i,i+1,j,j+1}]]=(({{1, -1, 0, 0}, {0, (T^s)-1, 1, -(T^s)}})),{c,Cs}];
A=B[[All,2;;]];
Δ=(T^((Total[r]-Total[First/@Cs])/2))Det[A];
G=Prepend[Table[0,2n]][Inverse[A]]; (Subscript[g, α_,β_]):=G[[α,β]];
p1=Sum[{s,i,j}=c;s(2(Subscript[g, i,i])(Subscript[g, i,j])-(Subscript[g, i,i])(Subscript[g, j,j])-(Subscript[g, i,j])(Subscript[g, j,i])+(1-(T^s))((Subscript[g, i,j]^2)-(Subscript[g, i,j])(Subscript[g, j,j]))-(Subscript[g, i,j])+(Subscript[g, j,j])-1/2),{c,Cs}];
p1+=Sum[r[[k]]((Subscript[g, k,k])-1/2),{k,2n}] ;
Factor@{Δ,T(((Δ^2)p1)/(((T-1))^2))}];

Table[Expand@PAI[K], {K,AllKnots[{3,6}]}]//Column

Sum[Simplify[Alexander[K][T]==PAI[K][[1]]], {K, AllKnots[{3,7}]}]

Timing@Sum[Simplify[Alexander[K][T]==PAI[K][[1]]], {K, AllKnots[{3,10}]}]

K=GST48;
Factor@Alexander[K][T]

Timing@PAI[GST48]

Alex2[K_]:=Module[{Cs,r,n,rot,w,B,A,c,s,i,j,Δ,G,g,a2},
{Cs,r}=List@@RVK[K] /. {Xp[i_,j_]:>{+1,i,j},Xm[i_,j_]:>{-1,i,j}};
n=Length[Cs];rot=Total[r]; w=Total[First/@Cs];
B=Table[0,2n,2n+1];
Do[{s,i,j}=c;B[[{i,j},{i,i+1,j,j+1}]]=(({{1, -1, 0, 0}, {0, (T^s)-1, 1, -(T^s)}})),{c,Cs}];
Δ=(T^((rot-w)/2))Det[A=B[[All,2;;]]];
G=Prepend[Table[0,2n]][Inverse[A]]; (Subscript[g, α_,β_]):=G[[α,β]];
a2=Sum[{s,i,j}=c;s((Subscript[g, i,j])-(Subscript[g, j,j])),{c,Cs}]+(rot+w)/2;
Expand@Together@{Δ,T(∂_T)Δ,Δ a2} ];
MatrixForm[Alex2/@AllKnots[{3,8}]]