Pensieve header: Knot Signatures as in KnotTheory` and as in Kashaev. Continues pensieve://Projects/Signatures/AsInKT.nb.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\Signatures"];
<< Common.m

Tristram-Levine

{\def\nbpdfText#1{\[\includegraphics[width=\linewidth]{#1}\]}

}

TLS1[K_,ω_]:=Module[{spd,a,s=0,c,cs,A,is},
spd=Times@@PD[K]/.x_X:>If[PositiveQ@x,Xp,Xm]@@x;
cs=spd/.{
Xp[i_,j_,k_,l_]:>(Subscript[a, j,i])[++s](Subscript[a, k,-j])[++s](Subscript[a, -l,-k])[++s](Subscript[a, -i,l])[++s],Xm[i_,j_,k_,l_]:>(Subscript[a, -j,i])[++s](Subscript[a, k,j])[++s](Subscript[a, l,-k])[++s](Subscript[a, -i,-l])[++s]
}//.(Subscript[a, i_,j_])[x__](Subscript[a, j_,k_])[y__]:>(Subscript[a, i,k])[x,y]/.(Subscript[a, __])[x__]:>a[x];
A=Table[0,Length@cs,Length@cs];
Do[is=Position[cs,4i-#][[1,1]]&/@{3,2,1,0};
A[[is,is]]+=If[spd[[i,0]]===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]} ];
Total[Sign[Select[
Eigenvalues[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]],Abs[#]>(10^(-6))&]]] ];

Plot[TLS1[Knot@"K12a422",(E^(I t))], {t,0,2π}]

Total[(TLS1[#,-1]==-KnotSignature[#])&/@AllKnots[{3,10}]]

K=Knot[4,1];
ω=(E^(2π I RandomReal[]))

{spd,a,s=0,c,cs,A,is}

PD[K]

spd=Times@@PD[K]/.x_X:>If[PositiveQ@x,Xp,Xm]@@x

spd/.{
Xp[i_,j_,k_,l_]:>(Subscript[a, j,i])[++s](Subscript[a, k,-j])[++s](Subscript[a, -l,-k])[++s](Subscript[a, -i,l])[++s],Xm[i_,j_,k_,l_]:>(Subscript[a, -j,i])[++s](Subscript[a, k,j])[++s](Subscript[a, l,-k])[++s](Subscript[a, -i,-l])[++s]
}

s=0; spd/.{
Xp[i_,j_,k_,l_]:>(Subscript[a, j,i])[++s](Subscript[a, k,-j])[++s](Subscript[a, -l,-k])[++s](Subscript[a, -i,l])[++s],Xm[i_,j_,k_,l_]:>(Subscript[a, -j,i])[++s](Subscript[a, k,j])[++s](Subscript[a, l,-k])[++s](Subscript[a, -i,-l])[++s]
}//.(Subscript[a, i_,j_])[x__](Subscript[a, j_,k_])[y__]:>(Subscript[a, i,k])[x,y]

s=0; cs=spd/.{
Xp[i_,j_,k_,l_]:>(Subscript[a, j,i])[++s](Subscript[a, k,-j])[++s](Subscript[a, -l,-k])[++s](Subscript[a, -i,l])[++s],Xm[i_,j_,k_,l_]:>(Subscript[a, -j,i])[++s](Subscript[a, k,j])[++s](Subscript[a, l,-k])[++s](Subscript[a, -i,-l])[++s]
}//.(Subscript[a, i_,j_])[x__](Subscript[a, j_,k_])[y__]:>(Subscript[a, i,k])[x,y]/.(Subscript[a, __])[x__]:>a[x]

A=Table[0,Length@cs,Length@cs]

A//MatrixForm

i=1; is=Position[cs,4i-#][[1,1]]&/@{3,2,1,0}

A[[is,is]]

A[[is,is]]+=If[spd[[i,0]]===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}}))]

A//MatrixForm

i=2; is=Position[cs,4i-#][[1,1]]&/@{3,2,1,0}

A[[is,is]]+=If[spd[[i,0]]===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}}))]

A//MatrixForm

i=3; is=Position[cs,4i-#][[1,1]]&/@{3,2,1,0}

A[[is,is]]+=If[spd[[i,0]]===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}}))]

A//MatrixForm

i=4; is=Position[cs,4i-#][[1,1]]&/@{3,2,1,0}

A[[is,is]]+=If[spd[[i,0]]===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}}))]

A//MatrixForm

MatrixForm[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]]

Eigenvalues[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]]

Select[
Eigenvalues[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]],Abs[#]>(10^(-6))&]

Sign[Select[
Eigenvalues[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]],Abs[#]>(10^(-6))&]]

Total[Sign[Select[
Eigenvalues[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]],Abs[#]>(10^(-6))&]]]

Total[Sign[Select[
Eigenvalues[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]],Abs[#]>(10^(-6))&]]]

A new TLS program

Clear[ω]

A=(({{0, 0, 0, 0}, {1, -1, 0, 0}, {0, -1, 0, 1}, {-1, 2, 0, -1}})); MatrixForm[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]]

A=(({{1, -1, 0, 0}, {0, 0, 0, 0}, {-2, 1, 1, 0}, {1, 0, -1, 0}})); MatrixForm[(1-ω)A+(1-ω\[Conjugate])A\[Transpose]]

TLS2[K_,ω_]:=Module[{spd,a,s=0,c,cs,A,is},
spd=Times@@PD[K]/.x_X:>If[PositiveQ@x,Xp,Xm]@@x;
cs=spd/.{
Xp[i_,j_,k_,l_]:>(Subscript[a, j,i])[++s](Subscript[a, k,-j])[++s](Subscript[a, -l,-k])[++s](Subscript[a, -i,l])[++s],Xm[i_,j_,k_,l_]:>(Subscript[a, -j,i])[++s](Subscript[a, k,j])[++s](Subscript[a, l,-k])[++s](Subscript[a, -i,-l])[++s]
}//.(Subscript[a, i_,j_])[x__](Subscript[a, j_,k_])[y__]:>(Subscript[a, i,k])[x,y]/.(Subscript[a, __])[x__]:>a[x];
A=Table[0,Length@cs,Length@cs];
Do[is=Position[cs,4i-#][[1,1]]&/@{3,2,1,0};
A[[is,is]]+=If[spd[[i,0]]===Xp,
(({{0, 1-ω\[Conjugate], 0, -1+ω\[Conjugate]}, {1-ω, -2+ω+ω\[Conjugate], -1+ω\[Conjugate], 2 (1-ω\[Conjugate])}, {0, -1+ω, 0, 1-ω}, {-1+ω, 2 (1-ω), 1-ω\[Conjugate], -2+ω+ω\[Conjugate]}})),(({{2-ω-ω\[Conjugate], -1+ω, -2 (1-ω\[Conjugate]), 1-ω\[Conjugate]}, {-1+ω\[Conjugate], 0, 1-ω\[Conjugate], 0}, {-2 (1-ω), 1-ω, 2-ω-ω\[Conjugate], -1+ω\[Conjugate]}, {1-ω, 0, -1+ω, 0}}))
],
{i,Length[spd]} ];
Total[Sign[Select[Eigenvalues[A],Abs[#]>(10^(-6))&]]]
];

Plot[TLS2[Knot@"K12a422",(E^(I t))], {t,0,2π}]

Kashaev

KC for “Kashaev’s Conjecture”.

KC[K_,x1_,x2_]:=Module[{spd,a,s=0,c,cs,A,is,w=0},
spd=Times@@PD[K]/.x_X:>If[PositiveQ@x,Xp,Xm]@@x;
cs=spd/.{
Xp[i_,j_,k_,l_]:>(Subscript[a, j,i])[++s](Subscript[a, k,-j])[++s](Subscript[a, -l,-k])[++s](Subscript[a, -i,l])[++s],Xm[i_,j_,k_,l_]:>(Subscript[a, -j,i])[++s](Subscript[a, k,j])[++s](Subscript[a, l,-k])[++s](Subscript[a, -i,-l])[++s]
}//.(Subscript[a, i_,j_])[x__](Subscript[a, j_,k_])[y__]:>(Subscript[a, i,k])[x,y]/.(Subscript[a, __])[x__]:>a[x];
A=Table[0,Length@cs,Length@cs];
Do[is=Position[cs,4i-#][[1,1]]&/@{3,2,1,0};
A[[is,is]]+=If[spd[[i,0]]===Xp,
++w;(({{1, x1, 1, x1}, {x1, x2 , x1, 1}, {1, x1, 1, x1}, {x1, 1, x1, x2}})),--w;(({{-x2, -x1, -1, -x1}, {-x1, -1, -x1, -1}, {-1, -x1, -x2, -x1}, {-x1, -1, -x1, -1}}))
],
{i,Length[spd]} ];
(Total[Sign[Select[Eigenvalues[A],Abs[#]>(10^(-6))&]]]-w)/2
];

t = RandomReal[{0,2*π}]
ω=E^(I*t);
x1  = (1/2)*(E^((1/2)*I*t) + E^(-(1/2)*I*t));
x2 = (1/2)*(E^(I*t) + E^(-I*t));
Total[(KC[#,x1,x2]==TLS2[#,ω])&/@AllKnots[{3,10}]]

KC2[K_,x1_,x2_]:=Module[{spd,a,s=0,c,cs,A,is,w=0},
spd=Times@@PD[K]/.x_X:>If[PositiveQ@x,Xp,Xm]@@x;
cs=spd/.{
Xp[i_,j_,k_,l_]:>(Subscript[a, j,i])[++s](Subscript[a, k,-j])[++s](Subscript[a, -l,-k])[++s](Subscript[a, -i,l])[++s],Xm[i_,j_,k_,l_]:>(Subscript[a, -j,i])[++s](Subscript[a, k,j])[++s](Subscript[a, l,-k])[++s](Subscript[a, -i,-l])[++s]
}//.(Subscript[a, i_,j_])[x__](Subscript[a, j_,k_])[y__]:>(Subscript[a, i,k])[x,y]/.(Subscript[a, __])[x__]:>a[x];
A=Table[0,Length@cs,Length@cs];
Do[is=Position[cs,4i-#][[1,1]]&/@{3,2,1,0};
A[[is,is]]+=If[spd[[i,0]]===Xp,
++w;(({{1, x1, 1, x1}, {x1, x2 , x1, 1}, {1, x1, 1, x1}, {x1, 1, x1, x2}}))-(({{1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}})),--w;(({{-x2, -x1, -1, -x1}, {-x1, -1, -x1, -1}, {-1, -x1, -x2, -x1}, {-x1, -1, -x1, -1}}))+(({{1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}}))
],
{i,Length[spd]} ];
(Total[Sign[Select[Eigenvalues[A],Abs[#]>(10^(-6))&]]])/2
];

t = RandomReal[{0,2*π}]
ω=E^(I*t);
x1  = (1/2)*(E^((1/2)*I*t) + E^(-(1/2)*I*t));
x2 = (1/2)*(E^(I*t) + E^(-I*t));
Total[(KC2[#,x1,x2]==TLS2[#,ω])&/@AllKnots[{3,10}]]