Pensieve header: Modified from Roland’s Dropbox/RhoRho/rhorho.nb

Once[<<KnotTheory`];

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[δ, i_,j_]):=If[i===j,1,0];
(Subscript[gRules, s_,i_,j_]):={(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(T^s)(Subscript[g, (SuperPlus[i]),β])+(1-(T^s))(Subscript[g, (SuperPlus[j]),β]),(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(Subscript[g, (SuperPlus[j]),β]),
(Subscript[g, α_,i]):>(T^(-s))((Subscript[g, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[g, α_,j]):>(Subscript[g, α,(SuperPlus[j])])-(1-(T^s))(Subscript[g, α,i])-(Subscript[δ, α,(SuperPlus[j])])}
(Subscript[fRules, s_,i_,j_]):={(Subscript[f, i,β_]):>(Subscript[δ, i,β])+(F^s)(Subscript[f, (SuperPlus[i]),β])+(1-(F^s))(Subscript[f, (SuperPlus[j]),β]),(Subscript[f, j,β_]):>(Subscript[δ, j,β])+(Subscript[f, (SuperPlus[j]),β]),
(Subscript[f, α_,i]):>(F^(-s))((Subscript[f, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[f, α_,j]):>(Subscript[f, α,(SuperPlus[j])])-(1-(F^s))(Subscript[f, α,i])-(Subscript[δ, α,(SuperPlus[j])])}
(SuperPlus[((SuperPlus[α_]))]):=(α^("++"));

The ansatz for R, (R^(-1)) and C

(Subscript[R, 1])[1,i_,j_]:=Module[{gfs=Join[Flatten@Table[(Subscript[f, a,b]),{a,{i,j}},{b,{i,j}}],
Flatten@Table[(Subscript[g, a,b]),{a,{i,j}},{b,{i,j}}]]},
DeleteDuplicates[Times@@@Tuples[
gfs,2]].Table[(Subscript[r, k]),{k,36}]+
gfs.Table[(Subscript[r, k]),{k,36+1,36+8}]+ (Subscript[r, 36+9])]
(Subscript[R, 1])[-1,i_,j_]:=Module[{gfs=Join[Flatten@Table[(Subscript[f, a,b]),{a,{i,j}},{b,{i,j}}],
Flatten@Table[(Subscript[g, a,b]),{a,{i,j}},{b,{i,j}}]]},
DeleteDuplicates[Times@@@Tuples[
gfs,2]].Table[(Subscript[q, k]),{k,36}]+
gfs.Table[(Subscript[q, k]),{k,36+1,36+8}]+ (Subscript[q, 36+9])]
(* modified expression for the curl: *)
CC[s_,i_]:=s ((Subscript[c, 1 ])(Subscript[f, i,i])+(Subscript[c, 2])(Subscript[g, i,i])+(Subscript[c, 3]))

(Subscript[R, 1])[1,i,j]

The Reidemeister moves as equations

lhs3=(Subscript[R, 1])[1,j,k]+(Subscript[R, 1])[1,i,(SuperPlus[k])]+(Subscript[R, 1])[1,(SuperPlus[i]),(SuperPlus[j])]//.(Subscript[gRules, 1,j,k])⋃(Subscript[gRules, 1,i,(SuperPlus[k])])⋃(Subscript[gRules, 1,(SuperPlus[i]),(SuperPlus[j])])⋃(Subscript[fRules, 1,j,k])⋃(Subscript[fRules, 1,i,(SuperPlus[k])])⋃(Subscript[fRules, 1,(SuperPlus[i]),(SuperPlus[j])]);
rhs3=(Subscript[R, 1])[1,i,j]+(Subscript[R, 1])[1,(SuperPlus[i]),k]+(Subscript[R, 1])[1,(SuperPlus[j]),(SuperPlus[k])]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, 1,(SuperPlus[i]),k])⋃(Subscript[gRules, 1,(SuperPlus[j]),(SuperPlus[k])])⋃(Subscript[fRules, 1,i,j])⋃(Subscript[fRules, 1,(SuperPlus[i]),k])⋃(Subscript[fRules, 1,(SuperPlus[j]),(SuperPlus[k])]);

lhs2c=(Subscript[R, 1])[-1,i,(SuperPlus[j])]+(Subscript[R, 1])[1,(SuperPlus[i]),j]+CC[1,(SuperPlus[j])]//.(Subscript[gRules, -1,i,(SuperPlus[j])])⋃(Subscript[gRules, 1,(SuperPlus[i]),j])⋃(Subscript[fRules, -1,i,(SuperPlus[j])])⋃(Subscript[fRules, 1,(SuperPlus[i]),j]);
rhs2c=CC[1,(SuperPlus[((SuperPlus[j]))])];

lhs1l=(Subscript[R, 1])[1,(SuperPlus[i]),i]+CC[1,(SuperPlus[i])]//.{(Subscript[g, (SuperPlus[i]),β_]):>(T^(-1))(Subscript[δ, (SuperPlus[i]),β])+(Subscript[g, (i^("++")),β]),(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(Subscript[g, (SuperPlus[i]),β]),
(Subscript[g, α_,(SuperPlus[i])]):>(T^(-1))((Subscript[g, α,(i^("++"))])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[g, α_,i]):>T (Subscript[g, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])]),
(Subscript[f, (SuperPlus[i]),β_]):>(F^(-1))(Subscript[δ, (SuperPlus[i]),β])+(Subscript[f, (i^("++")),β]),(Subscript[f, i,β_]):>(Subscript[δ, i,β])+(Subscript[f, (SuperPlus[i]),β]),
(Subscript[f, α_,(SuperPlus[i])]):>(F^(-1))((Subscript[f, α,(i^("++"))])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[f, α_,i]):>T (Subscript[f, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])};
lhs1r=(Subscript[R, 1])[1,i,(SuperPlus[i])]+CC[-1,(SuperPlus[i])]//.{
(Subscript[g, i,β_]):>(Subscript[δ, i,β])+T (Subscript[g, (SuperPlus[i]),β])+(1-T)(Subscript[g, (SuperPlus[(SuperPlus[i])]),β]),(Subscript[g, (SuperPlus[i]),β_]):>(Subscript[δ, (SuperPlus[i]),β])+(Subscript[g, (SuperPlus[(SuperPlus[i])]),β]),
(Subscript[g, α_,i]):>(T^(-1))((Subscript[g, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[g, α_,(SuperPlus[i])]):>T (Subscript[g, α,(SuperPlus[(SuperPlus[i])])])-(1-T)(Subscript[δ, α,(SuperPlus[i])])-T (Subscript[δ, α,(SuperPlus[(SuperPlus[i])])]),
(Subscript[f, i,β_]):>(Subscript[δ, i,β])+F (Subscript[f, (SuperPlus[i]),β])+(1-F)(Subscript[f, (SuperPlus[(SuperPlus[i])]),β]),(Subscript[f, (SuperPlus[i]),β_]):>(Subscript[δ, (SuperPlus[i]),β])+(Subscript[f, (SuperPlus[(SuperPlus[i])]),β]),
(Subscript[f, α_,i]):>(F^(-1))((Subscript[f, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[f, α_,(SuperPlus[i])]):>T (Subscript[f, α,(SuperPlus[(SuperPlus[i])])])-(1-F)(Subscript[δ, α,(SuperPlus[i])])-F (Subscript[δ, α,(SuperPlus[(SuperPlus[i])])])};
rhs1l=0;
rhs1r=0;
lhssw=(Subscript[R, 1])[1,i,j]+CC[-1,i]+CC[-1,j]+CC[1,(SuperPlus[i])]+CC[1,(SuperPlus[j])]//.(Subscript[gRules, 1,i,j])⋃(Subscript[fRules, 1,i,j]);
rhssw=(Subscript[R, 1])[1,i,j]//.(Subscript[gRules, 1,i,j])⋃(Subscript[fRules, 1,i,j]);

Solve for the coefficients in the Reidemeister equations

V=Join[Flatten@Table[(Subscript[g, a,b]),{a,{(i^("++")),(j^("++")),(k^("++"))}},{b,{(i^("++")),(j^("++")),(k^("++"))}}],Flatten@Table[(Subscript[f, a,b]),{a,{(i^("++")),(j^("++")),(k^("++"))}},{b,{(i^("++")),(j^("++")),(k^("++"))}}]];
eq3=Thread[Last/@CoefficientRules[lhs3-rhs3,V]==0];
eq2c=Thread[Last/@CoefficientRules[lhs2c-rhs2c,V]==0];
eq1l=Thread[Last/@CoefficientRules[lhs1l-rhs1l,V]==0];
eq1r=Thread[Last/@CoefficientRules[lhs1r-rhs1r,V]==0];
eqsw=Thread[Last/@CoefficientRules[lhssw-rhssw,V]==0];

Soln=First@Solve[Join[eq3,eq2c,eq1l,eq1r,eqsw],Join[Table[(Subscript[q, i]),{i,1,45}],Table[(Subscript[r, i]),{i,1,45}],Table[(Subscript[c, i]),{i,1,2}]]]//Simplify

CCC[s_,i_]:=s(CC[1,i]/.Soln)

CC[1,i]/.Soln
(Subscript[R, 1])[1,i,j]/.Soln
(Subscript[R, 1])[-1,i,j]/.Soln

CCC[s_,i_]:=s(CC[1,i]/.Soln)
(Subscript[RR, 1])[1,i_,j_]:=(Subscript[R, 1])[1,i,j]/.Soln
(Subscript[RR, 1])[-1,i_,j_]:=(Subscript[R, 1])[-1,i,j]/.Soln
ρρ[K_]:=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,FF,ρ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];FF=G/.T->F;
ρ1=(∑_(k=1)^n)(Subscript[RR, 1])@@Cs[[k]] + (∑_(k=1)^(2n))φ[[k]]CCC[1,k];
Factor@{Δ,((Δ^2)/.T->F)(Δ^2)ρ1/.(SuperPlus[α_]):>α+1/.{(Subscript[g, α_,β_]):>G[[α,β]],(Subscript[f, α_,β_]):>FF[[α,β]]}}];
(Subscript[Rold, 1])[s_,i_,j_]:=s((Subscript[g, j,i])((Subscript[g, (SuperPlus[j]),j])+(Subscript[g, j,(SuperPlus[j])])-(Subscript[g, i,j]))-(Subscript[g, i,i])((Subscript[g, j,(SuperPlus[j])])-1)-1/2);
Cold[s_,i_]:=s(-(Subscript[g, i,i])+(1/2))
ρ[K_]:=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,FF,ρ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[Rold, 1])@@Cs[[k]]))+ (∑_(k=1)^(2n))φ[[k]]Cold[1,k];
Factor@{Δ,(Δ^2)ρ1/.(SuperPlus[α_]):>α+1/.{(Subscript[g, α_,β_]):>G[[α,β]]}}];

ρ[Knot[3,1]]
Expand[(F^2) ρρ[Knot[3,1]]]/.F->0

(*ρρ does not distinguish the famous mutants*)
ρρ[Knot[11,NonAlternating,34]]==
ρρ[Knot[11,NonAlternating,42]]

(*Yet ρρ does outperform our usual ρ=ρ1 a little on all 11 crossing non-alternating knots:*)

ρ11na = ρ/@Table[PD@Knot[11,NonAlternating,k],{k,1,185}];

ρρ11na = ρρ/@Table[PD@Knot[11,NonAlternating,k],{k,1,185}];

Tally[ρ11na]//Length
Tally[Factor[ρρ11na]]//Length

Thread[ρρ11na[[3]]==Factor[ρρ11na[[3]]]]

Select[Tally[ρ11na], #[[2]]>1&]

AllKnots[{3,12}]//Length

ρ12 = ρ/@AllKnots[{3,12}];

ρρ12 = Factor[ρρ/@AllKnots[{3,12}]];

Tally[ρ12]//Length
Tally[ρρ12]//Length