Pensieve header: An analysis of K15a55264 and K15n90489 and more following their discovery on November 5, 2022 and on by SideBySide.nb. Continued in PossibleCounterexamples.nb at pensieve://Talks/ICERM-2305/.

Once[<< KnotTheory`]

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

MS[{}]=0;
MS[A_?MatrixQ]/;A==A\[Transpose]:=Module[{k,a,A1,j,l},
{k}=FirstPosition[A[[1]],x_/;x!=0,{None}];
Switch[k,
None, MS[A[[2;;,2;;]]],
1,(
a=A[[1,1]];
Sign[a]+MS[
A[[2;;,2;;]]-Outer[Times,A[[2;;,1]],A[[1,2;;]]]/a
]),
_,(
A1=A; A1[[k]]/=A[[k,1]]; A1[[All,k]]/=A[[1,k]];
a=A1[[k,k]]; A1[[k]]-=a A1[[1]]/2; A1[[All,k]]-=a A1[[All,1]]/2;
For[j=2,j<=Length@A,++j,If[j!=k,
A1[[j]]-=A1[[j,1]]A1[[k]]+A1[[j,k]]A1[[1]];
A1[[;;,j]]-=A1[[1,j]]A1[[;;,k]]+A1[[k,j]]A1[[;;,1]]
]];
l=Complement[Range@Length@A,{1,k}];
MS[A1[[l,l]]]
)
]
]

The Bedlewo program

Bed[K_,ω_]:=Module[{t,r,XingsByArmpits,bends,faces,p,A,is},
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}];
MatrixSignature[A] ];

Plot[Bed[K=Knot[8,2],(E^(I t))], {t,0,2π}]
PositiveQ/@(List@@PD[K])

Draw[Knot[8,2]]

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

The Kashaev Program

Kas[K_,ω_]:=Module[{u,v,XingsByArmpits,bends,faces,p,A,is},
u=Re[(ω^(1/2))]; v= Re[ω]; (* so v=2(u^2)-1 *);
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}];
(MatrixSignature[A]-Writhe[K])/2 ];

Plot[Kas[Knot[5,1],(E^(I t))], {t,0,2π}]

Comparisons

Sum[ω=(E^(I RandomReal[{0,2π}])); Bed[K,ω]==Kas[K,ω], {10}, {K,AllKnots[{3,10}]}]

Table[Bed[K,I],{K,AllKnots[{3,5}]}]

Table[KnotSignature[K],{K,AllKnots[{3,5}]}]

Total@Table[Bed[K,-1]==-KnotSignature[K], {K,AllKnots[{3,10}]}]

(Subscript[10, 98])

K=Knot[10,98]

Alexander[K][T]//Factor

Plot[Kas[K,(E^(I t))], {t,0,2π}]

Plot[Bed[K,(E^(I t))], {t,1.047,1.0475}]

Plot[Kas[K,(E^(I t))], {t,1.047,1.0475}]

K11n72

K=Knot[11,NonAlternating,72];
Alexander[K][T]//Factor

Plot[Kas[K,(E^(I t))], {t,0,2π}]

Plot[Bed[K,(E^(I t))], {t,1.047,1.0475}]

Plot[Kas[K,(E^(I t))], {t,1.047,1.0475}]

K15a55264 and K15n90489 and more

{K1,ω1}={Knot[15,Alternating,55264],0.5023868946758996` -0.8646429367420442` I};
{K2,ω2}={Knot[15,NonAlternating,90489],0.4973889914966496` -0.8675276313397434` I};
{K3,ω3}={Knot[16,Alternating,144399],0.5000006342255959` +0.8660250376138104` I};
{K4,ω4}={Knot[16,NonAlternating,225282],0.5005898353703419` -0.8656845942512169` I};
{K5,ω5}={Knot[16,NonAlternating,761158],0.4999164509765885` +0.8660736354623504` I};

Factor[Alexander[#][T]]& /@ {K1,K2,K3,K4,K5}

{Bed[K1,ω1],Kas[K1,ω1]}

θ1=Abs@Arg[ω1]

{Bed[K1,(E^(I θ1))],Kas[K1,(E^(I θ1))]}

Plot[Bed[K1,(E^(I t))], {t,0,2π}]

Plot[Kas[K1,(E^(I t))], {t,0,2π}]

Plot[Bed[K1,(E^(I t))], {t,θ1-0.001,θ1+0.001}]

Plot[Kas[K1,(E^(I t))], {t,θ1-0.001,θ1+0.001}]

K=K1;sqrtω=N[(E^((I/2) 10442/10000)),64]

t0=((Re[sqrtω])/(1-Im[sqrtω]))

t0=-1729057/1000000;
x0=((2t0)/(1+(t0^2))); y0=((1-(t0^2))/(1+(t0^2)));
{sqrtω=x0+I y0, N[sqrtω],Abs[sqrtω]}

Kas[K,N[((sqrtω)^2)]]

((sqrtω)^2)

Kas[K,((sqrtω)^2)]

u=Re[sqrtω]; v= Re[((sqrtω)^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}];
A//MatrixForm

Eigenvalues[A]//Sort

MatrixSignature[A]

MS[A]

(MatrixSignature[A]-Writhe[K])/2

(MS[A]-Writhe[K])/2

Alexander[K][T]//Factor

Solve[Alexander[K][T]==0,T]

Plot[Bed[K4,(E^(I t))], {t,0,2π}]

Clear[u,v];
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}];
A//MatrixForm

Plot[ω=(E^(I t)); Sort[Eigenvalues[A/.{u->Re[(ω^(1/2))],v-> Re[ω]}]],{t,0,2π} ]

Plot[ω=N[(E^(I t)),64]; Sort[Eigenvalues[A/.{u->Re[(ω^(1/2))],v-> Re[ω]}]][[6]],{t,θ1-0.001,θ1+0.001} ]

Plot[ω=N[(E^(I t)),64]; Sort[Eigenvalues[A/.{u->Re[(ω^(1/2))],v-> Re[ω]}]][[7]],{t,θ1-0.001,θ1+0.001} ]