Pensieve header: Compute the signatures of AllKnots[{3,12}].

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\ICERM-2305"];

Once[<< KnotTheory`];

θ[x_]/;NumericQ[x]:=UnitStep[x]

ω2[v_][p_]:=Module[{q=Expand[p],n,c},
If[q===0,0,c=Coefficient[q,ω,n=Exponent[q,ω]];c (v^n)+ω2[v][q-c(((ω+(ω^(-1))))^n)]]];

sign[ℰ_]:=Module[{n,d,v,p,rs,e,k},
{n,d}=NumeratorDenominator[ℰ];
{n,d}/=(ω^(Exponent[n,ω]/2+Exponent[n,ω,Min]/2));
p=Factor[ω2[v]@n*ω2[v]@d/.v->4(u^2)-2];
rs=Solve[p==0,u,Reals];
If[rs==={}, Sign[p/.u->0],
rs=Union@(u/.rs);
Sign[(((-1))^(e=Exponent[p,u]))Coefficient[p,u,e]]+Sum[
k=0;While[(d=RootReduce[(∂_({u,++k}))p/.u->r])==0];
If[EvenQ[k],0,2Sign[d]]*θ[u-r],
{r,rs}]
]
]

SetAttributes[B, Orderless];
CF[b_B]:=RotateLeft[#,First@Ordering[#]-1]&/@DeleteCases[b,{}]

CF[ℰ_]:=Module[{γs=Union@Cases[ℰ,(Subscript[γ, _])|(Subscript[(OverBar[γ]), _]),∞]},
Total[CoefficientRules[ℰ,γs]/.(ps_->c_):>Factor[c]Times@@((γs)^ps)] ]

CF[{}]={};
CF[𝒞_List]:=Module[{γs=Union@Cases[𝒞,(Subscript[γ, _]),∞],γ},
CF/@DeleteCases[0][
RowReduce[Table[(∂_γ)r,{r,𝒞},{γ,γs}]].γs]  ]

(SuperStar[(ℰ_)]):=ℰ/.{(OverBar[γ])->γ,γ->(OverBar[γ]),ω->(ω^(-1)),c_Complex:>c\[Conjugate]};
(SuperPlus[r_Rule]):={r,(SuperStar[r])}

RulesOf[(Subscript[γ, i_])+rest_.]:=(SuperPlus[((Subscript[γ, i])->-rest)]);
CF[PQ[𝒞_,q_]]:=Module[{n𝒞=CF[𝒞]},
PQ[n𝒞,CF[q/.Union@@RulesOf/@n𝒞]]  ]

CF[(Subscript[Σ, b_])[σ_,pq_]]:=(Subscript[Σ, CF[b]])[σ,CF[pq]]

Format[(Subscript[Σ, b_B])[σ_,PQ[𝒞_,q_]]]:=Module[{γs},
γs=(Subscript[γ, #])&/@Join@@b;
Column[{TraditionalForm@σ,
TableForm[Join[
Prepend[""]/@Table[TraditionalForm[(∂_c)r],{r,𝒞},{c,γs}],
{Prepend[""][
Join@@(b/.{l_,m___,r_}:>{DisplayForm@RowBox[{"(",l}],m,DisplayForm@RowBox[{r,")"}]})/.i_Integer:>(Subscript[γ, i]) ]},
MapThread[Prepend,{Table[TraditionalForm[(∂_(r,c))q],{r,(SuperStar[γs])},{c,γs}],(SuperStar[γs])}]
],TableAlignments->Center]
}, Center] ];

(Subscript[Σ, b1_])[σ1_,PQ[𝒞1_,q1_]]⊕(Subscript[Σ, b2_])[σ2_,PQ[𝒞2_,q2_]]^:=CF@(Subscript[Σ, Join[b1,b2]])[σ1+σ2,PQ[𝒞1⋃𝒞2,q1+q2]];

(Subscript[GT, i_,j_])@(Subscript[Σ, B[{li___,i_,ri___},{lj___,j_,rj___},bs___]])[σ_,PQ[𝒞_,q_]]:=CF@(Subscript[Σ, B[{ri,li,j,rj,lj,i},bs]])[σ,PQ[𝒞⋃{(Subscript[γ, i])-(Subscript[γ, j])},q]]

(Subscript[Cordon, i_])@(Subscript[Σ, B[{li___,i_,ri___},bs___]])[σ_,PQ[𝒞_,q_]]:=Module[{ϕ=(∂_(Subscript[γ, i]))𝒞,λ=(∂_((Subscript[(OverBar[γ]), i]),(Subscript[γ, i])))q,nσ=σ,n𝒞,nq,p},
{p}=FirstPosition[(#=!=0)&/@ϕ,True,{0}];
{n𝒞,nq}=Which[
p>0, {𝒞,q}/.(SuperPlus[((Subscript[γ, i])->-𝒞[[p]]/ϕ[[p]])])/.(SuperPlus[((Subscript[γ, i])->0)]),
λ=!=0,(nσ+=sign[λ];{𝒞,q/.(SuperPlus[((Subscript[γ, i])->-((∂_(Subscript[(OverBar[γ]), i]))q)/λ)])/.(SuperPlus[((Subscript[γ, i])->0)])}),
λ===0,{𝒞⋃{(∂_(Subscript[(OverBar[γ]), i]))q},q/.(SuperPlus[((Subscript[γ, i])->0)])}];
CF@(Subscript[Σ, B[Most@{ri,li},bs]])[nσ,PQ[n𝒞,nq]/.(SuperPlus[((Subscript[γ, Last@{ri,li}])->(Subscript[γ, First@{ri,li}]))])]  ]

(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{li___,i_,ri___},{___,j_,___},___]])[__]:=t//(Subscript[GT, j,First@{ri,li}])//(Subscript[Cordon, j])

(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{___,i_,j_,___},___]])[__]:=(Subscript[Cordon, j])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{j_,___,i_},___]])[__]:=(Subscript[Cordon, j])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{___,j_,i_,___},___]])[__]:=(Subscript[Cordon, i])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{i_,___,j_},___]])[__]:=(Subscript[Cordon, i])@t

mc[ℰ_]:=ℰ//.
t:(Subscript[Σ, B[{___,i_,___},{___,j_,___},___]])[__]|(Subscript[Σ, B[{___,i_,j_,___},___]])[__]|(Subscript[Σ, B[{j_,___,i_},___]])[__]/;i+j==0:>(Subscript[c, i,j])@t

Kas@(Subscript[P, i_,j_]):=CF@(Subscript[Σ, B[{i,j}]])[0,PQ[{},0]];
TL@(Subscript[P, i_,j_]):=CF@(Subscript[Σ, B[{i,j}]])[0,PQ[{},0]]

Kas[x:X[i_,j_,k_,l_]]:=Kas@If[PositiveQ[x],(Subscript[X, -i,j,k,-l]),(Subscript[(OverBar[X]), -j,k,l,-i])];
Kas[(Subscript[(x:X|(OverBar[X])), fs__])]:=Module[{v=2(u^2)-1,p,γs,m},
γs=(Subscript[γ, #])&/@{fs};p=(x===X);
m=If[p,(({{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}}))];
CF@(Subscript[Σ, B[{fs}]])[If[p,-1,1],PQ[{},(SuperStar[γs]).m.γs]]]

TL[x:X[i_,j_,k_,l_]]:=TL@If[PositiveQ[x],(Subscript[X, -i,j,k,-l]),(Subscript[(OverBar[X]), -j,k,l,-i])];
TL[(Subscript[(x:X|(OverBar[X])), fs__])]:=Module[{t=1-ω,r,γs,m},
r=t+(SuperStar[t]);γs=(Subscript[γ, #])&/@{fs};
m=If[x===X,
(({{-r, -t, 2t, (SuperStar[t])}, {-(SuperStar[t]), 0, (SuperStar[t]), 0}, {2(SuperStar[t]), t, -r, -(SuperStar[t])}, {t, 0, -t, 0}})),(({{r, -t, -2(SuperStar[t]), (SuperStar[t])}, {-(SuperStar[t]), 0, (SuperStar[t]), 0}, {-2t, t, r, -(SuperStar[t])}, {t, 0, -t, 0}}))];
CF@(Subscript[Σ, B[{fs}]])[0,PQ[{},(SuperStar[γs]).m.γs]]]

Kas[K_]:=Fold[mc[#1⊕#2]&,(Subscript[Σ, B[]])[0,PQ[{},0]],List@@(Kas/@PD@K)];
KasSig[K_]:=KasSig[K]=Expand[Kas[K][[1]]/2]

TL[K_]:=Fold[mc[#1⊕#2]&,(Subscript[Σ, B[]])[0,PQ[{},0]],List@@(TL/@PD@K)]/.θ[c_+u]/;Abs[c]>=1:>θ[c];
TLSig[K_]:=TLSig[K]=TL[K][[1]]

TLSig[Knot[3,1]]

Monitor[Table[K->TLSig[K],{K,AllKnots[{3,10}]}],K]

Table[K->TLSig[K],{K,AllKnots[{3,10}]}]>>TLSigData10.m

CountDistinct[Table[TLSig[K],{K,AllKnots[{3,10}]}]]

CountDistinct[Table[Alexander[K][T],{K,AllKnots[{3,10}]}]]

CountDistinct[Table[{TLSig[K], Alexander[K][T]},{K,AllKnots[{3,10}]}]]

vals=Sort@Table[{Alexander[K][T], TLSig[K],K},{K,AllKnots[{3,10}]}];
Table[
pair=vals[[{k,k+1}]];
If[pair[[1,1]]===pair[[2,1]]∧pair[[1,2]]=!=pair[[2,2]], Last/@pair,],
{k,NumberOfKnots[10]-1}
]//DeleteCases[Null]

pair={Knot[5,1],Knot[10,132]};
Alexander[#][T]& /@ pair
Plot[TLSig[#],{u,-1,1}]& /@pair

Monitor[Table[K->TLSig[K],{K,AllKnots[{3,12}]}],K]

Table[K->TLSig[K],{K,AllKnots[{3,12}]}]>>TLSigData12.m

Monitor[Table[K->TLSig[K],{K,AllKnots[{3,13}]}],K]

Table[K->TLSig[K],{K,AllKnots[{3,13}]}]>>"Data/3-13.m"

NumberOfKnots[14,Alternating]

Monitor[Table[K->TLSig[K], {K, AllKnots[14,Alternating][[1;;10000]]}] >> "Data/14a1-10000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[14,Alternating][[10001;;19536]]}] >> "Data/14a10001-19536.m", K]

NumberOfKnots[14,NonAlternating]

Monitor[Table[K->TLSig[K], {K, AllKnots[14,NonAlternating][[1;;10000]]}] >> "Data/14n1-10000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[14,NonAlternating][[10001;;20000]]}] >> "Data/14n10001-20000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[14,NonAlternating][[20001;;27436]]}] >> "Data/14n20001-27436.m", K]

NumberOfKnots[15,Alternating]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[1;;10000]]}] >> "Data/15a1-10000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[10001;;20000]]}] >> "Data/15a10001-20000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[20001;;30000]]}] >> "Data/15a20001-30000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[30001;;35000]]}] >> "Data/15a30001-35000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[35001;;40000]]}] >> "Data/15a35001-40000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[40001;;50000]]}] >> "Data/15a40001-50000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[50001;;60000]]}] >> "Data/15a50001-60000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[60001;;70000]]}] >> "Data/15a60001-70000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[70001;;80000]]}] >> "Data/15a70001-80000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,Alternating][[80001;;85263]]}] >> "Data/15a10001-85263.m", K]

NumberOfKnots[15,NonAlternating]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[1;;10000]]}] >> "Data/15n1-10000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[10001;;20000]]}] >> "Data/15n10001-20000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[20001;;30000]]}] >> "Data/15n20001-30000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[30001;;40000]]}] >> "Data/15n30001-40000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[40001;;50000]]}] >> "Data/15n40001-50000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[50001;;60000]]}] >> "Data/15n50001-60000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[60001;;70000]]}] >> "Data/15n60001-70000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[70001;;80000]]}] >> "Data/15n70001-80000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[80001;;90000]]}] >> "Data/15n80001-90000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[90001;;100000]]}] >> "Data/15n90001-100000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[100001;;110000]]}] >> "Data/15n100001-110000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[110001;;120000]]}] >> "Data/15n110001-120000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[120001;;130000]]}] >> "Data/15n120001-130000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[130001;;140000]]}] >> "Data/15n130001-140000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[140001;;150000]]}] >> "Data/15n140001-150000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[150001;;160000]]}] >> "Data/15n150001-160000.m", K]

Monitor[Table[K->TLSig[K], {K, AllKnots[15,NonAlternating][[160001;;168030]]}] >> "Data/15n160001-168030.m", K]

Ks=AllKnots[{3,15}];
$M=100;
Monitor[
Do[
Get[f]/.(K_->V_):>(TLSig[K]=V),
{f,FileNames["Data/*.m"]}
],
"Reading "<>f
];
Monitor[
Do[
f="Data/15X"<>ToString[r]<>"mod"<>ToString[$M]<>".m";
If[!FileExistsQ[f],
Put[
Table[
(K=Ks[[k+1]])->TLSig[K],
{k,r,Length[Ks]-1,$M}
],
f
]
],
{r,0,$M-1}
],
{f,k+1,K}
]

Monitor[
Do[
Get[f]/.(K_->V_):>(TLSig[K]=V),
{f,FileNames["Data/*.m"]}
],
"Reading "<>f
];
((#->TLSig[#])& /@ AllKnots[{3,15}]) >> "TLSigData.m"