Pensieve header: The Alexander polynomial using an $F\times F$ matrix.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\Signatures"];
Once[<<KnotTheory`]

A1[K_]:=Module[{spd,x,a,s=0,c,cs,A,is,M,es},
spd=(Times@@PD[K])/.x_X:>If[PositiveQ@x,Xp@@x,Xm@@x];
cs=spd/.{
Xp[i_,j_,k_,l_]:>a[j,++s,i]a[k,++s,-j]a[-l,++s,-k]a[-i,++s,l],Xm[i_,j_,k_,l_]:>a[-j,++s,i]a[k,++s,j]a[l,++s,-k]a[-i,++s,-l]
}//.a[i_,x__,j_]a[j_,y__,k_]:>a[i,x,y,k]/.a[i_,x__,j_]:>a[x];
A=Table[0,{Length[cs]},{Length[cs]}];
Do[is=Position[cs,#][[1,1]]&/@(4i-{3,2,1,0});
A[[is,is]]+=If[Head[spd[[i]]]===Xp,(({{0, 0, 0, 0}, {1, -1, 0, 0}, {0, -1, 0, 1}, {-1, 2, 0, -1}})),(({{1, -1, 0, 0}, {0, 0, 0, 0}, {-2, 1, 1, 0}, {1, 0, -1, 0}}))],
{i,Length[spd]} ];
MatrixForm[M=Factor[(ω A-A\[Transpose])/2]];
es=DeleteCases[Eigenvalues[M],0];
Simplify[Times@@es] ];

Table[Simplify[A1[K]/Alexander[K][ω]],{K,AllKnots[{3,8}]}]

Union@Table[Simplify[A1[K]/Alexander[K][ω]],{K,AllKnots[{3,12}]}]

MatrixForm@Table[{K,A1[K],Alexander[K][ω],Simplify[A1[K]/Alexander[K][ω]]},{K,AllKnots[{3,7}]}]

MatrixSignature[A_]:=Total[Sign[Select[Eigenvalues[A],Abs[#]>(10^(-12))&]]];
MatrixSignature[A_]:=Total[Sign[Eigenvalues[A]]];
Writhe[K_]:=Sum[If[PositiveQ[x],1,-1], {x,List@@PD@K}];

A2[K_]:=Module[{spd,x,a,s=0,c,cs,A,is,M,es},
spd=(Times@@PD[K])/.x_X:>If[PositiveQ@x,Xp@@x,Xm@@x];
cs=spd/.{
Xp[i_,j_,k_,l_]:>a[j,++s,i]a[k,++s,-j]a[-l,++s,-k]a[-i,++s,l],Xm[i_,j_,k_,l_]:>a[-j,++s,i]a[k,++s,j]a[l,++s,-k]a[-i,++s,-l]
}//.a[i_,x__,j_]a[j_,y__,k_]:>a[i,x,y,k]/.a[i_,x__,j_]:>a[x];
A=Table[0,{Length[cs]},{Length[cs]}];
Do[is=Position[cs,#][[1,1]]&/@(4i-{3,2,1,0});
A[[is,is]]+=If[Head[spd[[i]]]===Xp,(({{0, 0, 0, 0}, {1, -1, 0, 0}, {0, -1, 0, 1}, {-1, 2, 0, -1}})),(({{1, -1, 0, 0}, {0, 0, 0, 0}, {-2, 1, 1, 0}, {1, 0, -1, 0}}))],
{i,Length[spd]} ];
MatrixForm[M=Factor[(ω A-A\[Transpose])/2]];
es=DeleteCases[Eigenvalues[M],0];
{Length@spd,Length@es, MatrixSignature[A+A\[Transpose]],-KnotSignature[K],KnotDet[K],Writhe[K],Simplify[((Times@@es)/(Alexander[K][ω]))],K}
];

MatrixForm@Union@Table[A2[K],{K,AllKnots[{3,8}]}]

From the ICERM-2305 handout: t=1-ω; r=t+t*; v=Re[ω]; u=Re[(ω^(1/2))]

{A1p,A1m}={(({{0, 0, 0, 0}, {1, -1, 0, 0}, {0, -1, 0, 1}, {-1, 2, 0, -1}})),(({{1, -1, 0, 0}, {0, 0, 0, 0}, {-2, 1, 1, 0}, {1, 0, -1, 0}}))};
{TLp,TLm}={(({{-r, -t, 2 t, t\[Conjugate]}, {-t\[Conjugate], 0, t\[Conjugate], 0}, {2 t\[Conjugate], t, -r, -t\[Conjugate]}, {t, 0, -t, 0}})),(({{r, -t, -2 t\[Conjugate], t\[Conjugate]}, {-t\[Conjugate], 0, t\[Conjugate], 0}, {-2t, t, r, -t\[Conjugate]}, {t, 0, -t, 0}}))};

MatrixForm[lhs=RotateRight[(1-ω)A1p+(1-ω\[Conjugate])A1p\[Transpose],{1,1}]]
MatrixForm[rhs=TLp //. {t->1-ω, r->t+t\[Conjugate]}]
lhs==rhs

MatrixForm[lhs=(1-ω)A1m+(1-ω\[Conjugate])A1m\[Transpose]]
MatrixForm[rhs=TLm//. {t->1-ω, r->t+t\[Conjugate]}]
lhs==rhs

Barring mistakes, the following is equivalent to A1, but with methodology as in SideBySide.nb:

A3[K_]:=Module[{t,r,XingsByArmpits,bends,faces,p,A,is,es,keeps},
t=1-ω; r=t+t\[Conjugate];
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{-r, -t, 2 t, t\[Conjugate]}, {-t\[Conjugate], 0, t\[Conjugate], 0}, {2 t\[Conjugate], t, -r, -t\[Conjugate]}, {t, 0, -t, 0}})),(({{r, -t, -2 t\[Conjugate], t\[Conjugate]}, {-t\[Conjugate], 0, t\[Conjugate], 0}, {-2t, t, r, -t\[Conjugate]}, {t, 0, -t, 0}}))],
{x,XingsByArmpits}];
M=Factor[((1/2 )/((ω^(1/2))-(ω^(-1/2))))A/.ω\[Conjugate]->(ω^(-1))];
keeps=Complement[Range@Length@M,Union@@FirstPosition[1]/@NullSpace[M]];
Factor@Det[M[[keeps,keeps]]]
]
Table[Simplify[A3[K]/Alexander[K][ω]],{K,AllKnots[{3,8}]}]

Table[Simplify[A3[K]/Alexander[K][ω]],{K,AllKnots[{3,10}]}]

And here’s the Kas version:

A4[K_]:=Module[{u,v,XingsByArmpits,bends,faces,p,A,is,es},
v= (ω+ω\[Conjugate])/2; u=(Sqrt[(v+1)/2]);
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))],
{x,XingsByArmpits}];
M=Factor[A/.ω\[Conjugate]->(ω^(-1))];
es=DeleteCases[Eigenvalues[M],0];
Simplify[Times@@es]
];

tab=Table[K->Factor@FullSimplify[{A4[K],((A4[K])/((Alexander[K][ω])^2))}],{K,AllKnots[{3,10}]}];

Union@Exponent[tab[[All,2,2]],ω]

tab11=Table[K->Factor@FullSimplify[{A4[K],((A4[K])/((Alexander[K][ω])^2))}],{K,AllKnots[{11,11}]}];

Union@Exponent[tab11[[All,2,2]],ω]

Cases[tab11,p_/;Exponent[p[[2,2]],ω]==4]

A5[K_]:=Module[{u,v,XingsByArmpits,bends,faces,p,A,is,es,keeps},
v= (ω+ω\[Conjugate])/2; u=(Sqrt[(v+1)/2]);
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))],
{x,XingsByArmpits}];
M=Factor[A/.ω\[Conjugate]->(ω^(-1))];
keeps=Complement[Range@Length@M,Union@@FirstPosition[1]/@RowReduce@NullSpace[M]];
Factor@Det[M[[keeps,keeps]]]
];

tab=Table[K->Factor@FullSimplify[{A5[K],((A5[K])/((Alexander[K][ω])^2))}],{K,AllKnots[{3,10}]}];

tab[[1;;10]]//Column

Union@tab[[All,2,2]]

tab11=Table[K->Factor@FullSimplify[{A5[K],((A5[K])/((Alexander[K][ω])^2))}],{K,AllKnots[{11,11}]}];

Union@tab11[[All,2,2]]

Monitor[
tab12=Table[K->Factor@FullSimplify[{A5[K],((A5[K])/((Alexander[K][ω])^2))}],{K,AllKnots[{12,12}]}],
K];

Union@tab12[[All,2,2]]

A6[K_]:=Module[{u,v,XingsByArmpits,bends,faces,p,A,is,es,rad,throws,keeps},
v= (ω+ω\[Conjugate])/2; u=(Sqrt[(v+1)/2]);
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))],
{x,XingsByArmpits}];
M=Factor[A/.ω\[Conjugate]->(ω^(-1))];
rad=NullSpace[M];
throws=Union@@FirstPosition[1]/@RowReduce@rad;
keeps=Complement[Range@Length@M,throws];
Factor[((Det[M[[keeps,keeps]]])/((Det[rad[[All,throws]]])^2))]
];

Column@Table[K->Factor@FullSimplify[{A6[K],((A6[K])/((Alexander[K][ω])^2))}],{K,AllKnots[{3,7}]}]

A7[K_]:=Module[{u,v,XingsByArmpits,bends,faces,p,A,is,es,rad,throws,keeps},
v= (ω+ω\[Conjugate])/2; u=(Sqrt[(v+1)/2]);
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))],
{x,XingsByArmpits}];
M=Factor[A/.ω\[Conjugate]->(ω^(-1))];
throws=RandomChoice[Subsets[Range@Length@M,{2}]];
keeps=Complement[Range@Length@M,throws];
Factor[Det[M[[keeps,keeps]]]]
];
Column@Table[K->Factor@FullSimplify[{a7=A7[K],(a7/((Alexander[K][ω])^2))}],{K,AllKnots[{3,7}]}]

A8[K_]:=Module[{u,v,XingsByArmpits,bends,faces,p,A,is,es,rad,throws,keeps},
v= (ω+ω\[Conjugate])/2; u=(Sqrt[(v+1)/2]);
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))],
{x,XingsByArmpits}];
M=Factor[A/.ω\[Conjugate]->(ω^(-1))];
throws=Position[faces,#][[1,1]]&/@List@@XingsByArmpits[[1,1;;2]];
keeps=Complement[Range@Length@M,throws];
Factor[Det[M[[keeps,keeps]]]]
];
Column@Table[K->Factor@FullSimplify[{a8=A8[K],(a8/((Alexander[K][ω])^2))}],{K,AllKnots[{3,7}]}]

tab=Table[K->Factor@FullSimplify[{a8=A8[K],(a8/((Alexander[K][ω])^2))}],{K,AllKnots[{3,11}]}];

Union@tab[[All,2,2]]

MatrixSignature[A_]:=Total[Sign[Select[Eigenvalues[A],Abs[#]>(10^(-12))&]]];
Writhe[K_]:=Sum[If[PositiveQ[x],1,-1], {x,List@@PD@K}];
S8[K_,ω1_]:=Module[{u,v,XingsByArmpits,bends,faces,p,A,is,es,rad,throws,keeps},
v= (ω+ω\[Conjugate])/2; u=(Sqrt[(v+1)/2]);
XingsByArmpits=List@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ[x],(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
bends=Times@@XingsByArmpits/._[X][a_,b_,c_,d_]:>(Subscript[p, a,-d])(Subscript[p, b,-a])(Subscript[p, c,-b])(Subscript[p, d,-c]);
faces=bends//.(Subscript[p, x__,y_])(Subscript[p, y_,z__]):>(Subscript[p, x,y,z]);
A=Table[0,Length@faces,Length@faces];
Do[is=Position[faces,#][[1,1]]& /@ List@@x;
A[[is,is]]+=If[Head[x]===(SubPlus[X]),
(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))],
{x,XingsByArmpits}];
M=Factor[A/.ω\[Conjugate]->(ω^(-1))/.ω->ω1];
throws=Position[faces,#][[1,1]]&/@List@@XingsByArmpits[[1,1;;2]];
keeps=Complement[Range@Length@M,throws];
(MatrixSignature[M[[keeps,keeps]]]-Writhe[K])/2
];
Plot[S8[Knot[8,2],(E^(I t))], {t,0,2π}]
Plot[S8[Knot@"K12a422",(E^(I t))], {t,0,2π}]