Pensieve header: $\rho_1$ of ribbon knots with up to 10 crossings.

This is Rho1.nb of http://drorbn.net/j22/ap.

Once[<<KnotTheory`];

tab14=Get["C:\\drorbn\\AcademicPensieve\\Projects\\APAI\\Data\\Rho3-14.m"];
tab14 /. (K_->v_):>(ρ[K]=v);

Rot::usage="Rot[K] where K is any n-crossing knot presentation returns {Cs, φ}, where Cs is a length n list of crossings as triples {s,i,j} and φ is a lengtth 2n list of rotation numbers.";

PD[epd_EPD]:=PD@@epd/.{(Subscript[X, i_,j_]):>X[j,i+1,j+1,i],(Subscript[(OverBar[X]), i_,j_]):>X[j,i,j+1,i+1]}

Rot[pd_PD]:=Module[{n,xs,x,rots,Xp,Xm,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]];
]
];
{xs/.{Xp[i_,j_]:>{+1,i,j}, Xm[i_,j_]:>{-1,i,j}},rots} ];
Rot[K_]:=Rot[PD[K]];

(Subscript[R, 1])[s_,i_,j_]:=s((Subscript[g, j,i])((Subscript[g, j+1,j])+(Subscript[g, j,j+1])-(Subscript[g, i,j]))-(Subscript[g, i,i])((Subscript[g, j,j+1])-1)-1/2);
ρ[K_]:=ρ[K]=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,ρ1},
{Cs,φ}=Rot[K]; n=Length[Cs];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
Δ=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A];
G=Inverse[A];
ρ1=(∑_(k=1)^n)(Subscript[R, 1])@@Cs[[k]] - (∑_(k=1)^(2n))φ[[k]]((Subscript[g, k,k])-1/2);
Factor@{Δ,(Δ^2)ρ1/.(Subscript[g, α_,β_]):>G[[α,β]]}];

Ribbons from C:\drorbn\AcademicPensieve\Projects\PG\MakeTable.nb

Ribbons={Knot[0,1],Knot[6,1],Knot[8,8],Knot[8,9],Knot[8,20],Knot[9,27],Knot[9,41],Knot[9,46],Knot[10,3],Knot[10,22],Knot[10,35],Knot[10,42],Knot[10,48],Knot[10,75],Knot[10,87],Knot[10,99],Knot[10,123],Knot[10,129],Knot[10,137],Knot[10,140],Knot[10,153],Knot[10,155]}

ρ[Knot[8,20]]

Column[ρ/@Ribbons]

Table[Echo@{K,MemberQ[Ribbons,K],ρ@K},{K,AllKnots[{8,8}]}];

Table[
If[Head[Expand@PolynomialGCD[ρ[K][[1]],(∂_T)ρ[K][[1]]]]===Plus,
Echo@{K,MemberQ[Ribbons,K],ρ@K},
Nothing
],{K,AllKnots[]}]

ρ/@{"K11n34","K11n42"}

Table[gcd=PolynomialGCD[ρ[K][[1]],(∂_T)ρ[K][[1]]];
If[Head[Expand@gcd]===Plus,
Echo@{K,MemberQ[Ribbons,K],Factor@PolynomialRemainder[ρ[K][[2]],gcd,T]},
Nothing
],{K,AllKnots[{3,10}]}]

Table[
{ρ0,ρ1}=ρ[K];
gcd=PolynomialGCD[ρ0,(∂_T)ρ0];
If[PolynomialRemainder[ρ1,gcd,T]=!=0,
Echo@{K,ρ0,ρ1, Factor@PolynomialRemainder[ρ1,gcd,T]},
Nothing
],{K,AllKnots[{3,14}]}]

ρ@"K11n66"

ρ@"K12a169"

ρ@"K12n666"

FactorCount[K_] := Total[Last/@Select[FactorList@Alexander[K][T],Head[#[[1]]]===Plus&]]

FactorCount[Knot[8,17]]

FactorCount /@ AllKnots[{3,10}]

(#->ρ[#])& /@ Select[AllKnots[],FactorCount[#]>=4&]

FactorCountJ[K_] := Total[Last/@Select[FactorList@Jones[K][q],Head[#[[1]]]===Plus&]]

FactorCountJ /@ AllKnots[{3,10}]

FactorCount /@ AllKnots[{3,12}]//Histogram

FactorCountJ /@ AllKnots[{3,12}]//Histogram

Table[{FactorCount[K], BridgeIndex[K]},{K,AllKnots[{3,10}]}] //Tally

Table[{FactorCount[K], BridgeIndex[K]},{K,AllKnots[{3,10}]}] //Histogram3D