Pensieve header: The “Heisenberg” invariant at $k=1$.

(Subscript[PP, _])=Identity; $k=0;γ=γ;ℏ;

Once[<<KnotTheory`];

The “Speedy” Engine

Internal Utilities

Canonical Form:

CCF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[
Expand[ℰ] //. (E^(x_))(E^(y_)):>(E^(x+y)) /. (E^(x_)):>(E^(CCF[x]))];
CF[ℰ_List]:=CF/@ℰ;
CF[sd_SeriesData] := MapAt[CF,sd,3];
CF[ℰ_] := Module[
{vs=Cases[ℰ,(Subscript[(y|b|t|a|x|η|β|τ|α|ξ), _]),∞]⋃{y,b,t,a,x,η,β,τ,α,ξ}},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))]
];
CF[ℰ_𝔼]:=CF/@ℰ; CF[(Subscript[𝔼, sp___])[ℰs___]]:=CF/@(Subscript[𝔼, sp])[ℰs];

The Kronecker δ:

Kδ/:(Subscript[Kδ, i_,j_]):=If[i===j,1,0];

Equality, multiplication, and degree-adjustment of perturbed Gaussians; 𝔼[L,Q,P] stands for (e^(L+Q))P:

𝔼/:𝔼[L1_,Q1_,P1_]≡𝔼[L2_,Q2_,P2_]:=CF[L1==L2]∧CF[Q1==Q2]∧CF[Normal[P1-P2]==0];
𝔼/:𝔼[L1_,Q1_,P1_]𝔼[L2_,Q2_,P2_]:=𝔼[L1+L2,Q1+Q2,P1*P2];
(Subscript[𝔼[L_,Q_,P_], $k_]):=𝔼[L,Q,Series[Normal@P,{ϵ,0,$k}]];

Zip and Bind

Variables and their duals:

{(SuperStar[t]),(SuperStar[b]),(SuperStar[y]),(SuperStar[a]),(SuperStar[x]),(SuperStar[z])}={τ,β,η,α,ξ,ζ}; 
{(SuperStar[τ]),(SuperStar[β]),(SuperStar[η]),(SuperStar[α]),(SuperStar[ξ]),(SuperStar[ζ])}={t,b,y,a,x,z}; (SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]);

Upper to lower and lower to Upper:

U2l={(Subscript[B, i_]^(p_.)):>(E^(-p ℏ γ (Subscript[b, i]))),(B^(p_.)):>(E^(-p ℏ γ b)), (Subscript[T, i_]^(p_.)):>(E^(-p ℏ (Subscript[t, i]))),(T^(p_.)):>(E^(-p ℏ t)),(Subscript[𝒜, i_]^(p_.)):>(E^(p γ (Subscript[α, i]))),(𝒜^(p_.)):>(E^(p γ α))}; 
l2U={(E^(c_.(Subscript[b, i_])+d_.)):>(Subscript[B, i]^(-c/(ℏ γ)))(E^d),(E^(c_.b+d_.)):>(B^(-c/(ℏ γ)))(E^d),
(E^(c_.(Subscript[t, i_])+d_.)):>(Subscript[T, i]^(-c/ℏ))(E^d),(E^(c_.t+d_.)):>(T^(-c/ℏ))(E^d),
(E^(c_.(Subscript[α, i_])+d_.)):>(Subscript[𝒜, i]^(c/γ))(E^d),(E^(c_.α+d_.)):>(𝒜^(c/γ))(E^d),
(E^(ℰ_)):>(E^(Expand@ℰ))};

Derivatives in the presence of exponentiated variables:

(Subscript[D, b])[f_]:=(∂_b)f-ℏ γ B(∂_B)f; (Subscript[D, (Subscript[b, i_])])[f_]:=(∂_(Subscript[b, i]))f-ℏ γ (Subscript[B, i])(∂_(Subscript[B, i]))f;
(Subscript[D, t])[f_]:=(∂_t)f-ℏ T(∂_T)f; (Subscript[D, (Subscript[t, i_])])[f_]:=(∂_(Subscript[t, i]))f-ℏ (Subscript[T, i])(∂_(Subscript[T, i]))f; 
(Subscript[D, α])[f_]:=(∂_α)f+γ 𝒜 (∂_𝒜)f; (Subscript[D, (Subscript[α, i_])])[f_]:=(∂_(Subscript[α, i]))f+γ (Subscript[𝒜, i]) (∂_(Subscript[𝒜, i]))f;
(Subscript[D, v_])[f_]:=(∂_v)f; (Subscript[D, {v_,0}])[f_]:=f; (Subscript[D, {}])[f_]:=f; (Subscript[D, {v_,n_Integer}])[f_]:=(Subscript[D, v])[(Subscript[D, {v,n-1}])[f]];
(Subscript[D, {l_List,ls___}])[f_]:=(Subscript[D, {ls}])[(Subscript[D, l])[f]];

Finite Zips:

collect[sd_SeriesData, ζ_] := MapAt[collect[#,ζ]&,sd,3];
collect[ℰ_,ζ_] := Collect[ℰ,ζ];
(Subscript[Zip, {}])[P_]:=P;
(Subscript[Zip, ζs_])[Ps_List]:=(Subscript[Zip, ζs])/@Ps;
(Subscript[Zip, {ζ_,ζs___}])[P_] := 
(collect[P//(Subscript[Zip, {ζs}]),ζ] /. f_.(ζ^(d_.)):>((Subscript[D, {(SuperStar[ζ]),d}])[f]))/.(SuperStar[ζ])->0/.(((SuperStar[ζ])/.{b->B,t->T,α->𝒜})->1)

QZip implements the “Q-level zips” on 𝔼(L,Q,P)=(e^(L+Q))P(ϵ). Such zips regard the L variables as scalars.

(Subscript[QZip, ζs_List])@𝔼[L_,Q_,P_] := Module[{ζ,z,zs,c,ys,ηs,qt,zrule,ζrule,out},
zs=Table[(SuperStar[ζ]),{ζ,ζs}];
c=CF[Q/.Alternatives@@(ζs⋃zs)->0];
ys=CF@Table[(∂_ζ)(Q/.Alternatives@@zs->0),{ζ,ζs}];
ηs=CF@Table[(∂_z)(Q/.Alternatives@@ζs->0),{z,zs}];
qt=CF@Inverse@Table[(Subscript[Kδ, z,(SuperStar[ζ])])-(∂_(z,ζ))Q,{ζ,ζs},{z,zs}];
zrule=Thread[zs->CF[qt.(zs+ys)]];
ζrule=Thread[ζs->ζs+ηs.qt];
CF /@ 𝔼[L,c+ηs.qt.ys,Det[qt](Subscript[Zip, ζs])[P/.(zrule⋃ζrule)]] ];

LZip implements the “L-level zips” on 𝔼(L,Q,P)=((Pe)^(L+Q)). Such zips regard all of ((Pe)^Q) as a single”P”. Here the z’s are b and α and the ζ’s are β and a.

(Subscript[LZip, ζs_List])@𝔼[L_,Q_,P_] := Module[{ζ,z,zs,Zs,c,ys,ηs,lt,zrule,Zrule,ζrule,Q1,EEQ,EQ},
zs=Table[(SuperStar[ζ]),{ζ,ζs}];
Zs=zs/.{b->B,t->T,α->𝒜};
c=L/.Alternatives@@(ζs⋃zs)->0/.Alternatives@@Zs->1;
ys=Table[(∂_ζ)(L/.Alternatives@@zs->0),{ζ,ζs}];
ηs=Table[(∂_z)(L/.Alternatives@@ζs->0),{z,zs}];
lt=Inverse@Table[(Subscript[Kδ, z,(SuperStar[ζ])])-(∂_(z,ζ))L,{ζ,ζs},{z,zs}];
zrule=Thread[zs->lt.(zs+ys)];
Zrule=Join[zrule,zrule/.r_Rule:>((U=r[[1]]/.{b->B,t->T,α->𝒜})->(U/.U2l/.r//.l2U))];
ζrule=Thread[ζs->ζs+ηs.lt];
Q1=Q/.(Zrule⋃ζrule);
EEQ[ps___]:=EEQ[ps]=(CF[(E^(-Q1))(Subscript[D, Thread[{zs,{ps}}]])[(E^Q1)]]/.{Alternatives@@zs->0,Alternatives@@Zs->1});
CF@𝔼[c+ηs.lt.ys,Q1/.{Alternatives@@zs->0,Alternatives@@Zs->1},
Det[lt]((Subscript[Zip, ζs])[(EQ@@zs)(P/.(Zrule⋃ζrule))] /. Derivative[ps___][EQ][___] :> EEQ[ps] /. _EQ->1)  ] ];

(Subscript[B, {}])[L_,R_]:=L R;
(Subscript[B, {is__}])[L_𝔼,R_𝔼] := Module[{n},
Times[
L/.Table[(Subscript[(v:b|B|t|T|a|x|y), i])->(Subscript[v, n@i]),{i,{is}}],
R/.Table[(Subscript[(v:β|τ|α|𝒜|ξ|η), i])->(Subscript[v, n@i]),{i,{is}}]
] // (Subscript[LZip, Join@@Table[{(Subscript[β, n@i]),(Subscript[τ, n@i]),(Subscript[a, n@i])},{i,{is}}]]) // (Subscript[QZip, Join@@Table[{(Subscript[ξ, n@i]),(Subscript[y, n@i])},{i,{is}}]]) ];
(Subscript[B, is___])[L_,R_]:=(Subscript[B, {is}])[L,R];

𝔼 morphisms with domain and range.

(Subscript[B, is_List])[(Subscript[𝔼, d1_->r1_])[L1_,Q1_,P1_],(Subscript[𝔼, d2_->r2_])[L2_,Q2_,P2_]]:=(Subscript[𝔼, (d1⋃Complement[d2,is])->(r2⋃Complement[r1,is])])@@(Subscript[B, is])[𝔼[L1,Q1,P1],𝔼[L2,Q2,P2]];
(Subscript[𝔼, d1_->r1_])[L1_,Q1_,P1_]//(Subscript[𝔼, d2_->r2_])[L2_,Q2_,P2_] := (Subscript[B, r1⋂d2])[(Subscript[𝔼, d1->r1])[L1,Q1,P1],(Subscript[𝔼, d2->r2])[L2,Q2,P2]];
(Subscript[𝔼, d1_->r1_])[L1_,Q1_,P1_]≡(Subscript[𝔼, d2_->r2_])[L2_,Q2_,P2_] ^:= (d1==d2)∧(r1==r2)∧(𝔼[L1,Q1,P1]≡𝔼[L2,Q2,P2]);
(Subscript[𝔼, d1_->r1_])[L1_,Q1_,P1_](Subscript[𝔼, d2_->r2_])[L2_,Q2_,P2_] ^:= (Subscript[𝔼, (d1⋃d2)->(r1⋃r2)])@@(𝔼[L1,Q1,P1]𝔼[L2,Q2,P2]);
(Subscript[(Subscript[𝔼, dr_])[L_,Q_,P_], $k_]):=(Subscript[𝔼, dr])@@(Subscript[𝔼[L,Q,P], $k]);
(Subscript[𝔼, _])[ℰ___][i_]:={ℰ}[[i]];(Subscript[R, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[0,((Subscript[y, i])-(Subscript[y, j]))(Subscript[x, j]),1+ϵ ((Subscript[x, i]) (Subscript[y, i])-(Subscript[x, j]) (Subscript[y, i])-(Subscript[x, j]) (Subscript[y, j]))+(ϵ^2) (Sum[(Subscript[r, If[#===i,0,1]&@k,If[#===i,0,1]&@l])(Subscript[y, k])(Subscript[x, l]),{k,{i,j}},{l,{i,j}}]+Sum[(Subscript[s, If[#===i,0,1]&@k,If[#===i,0,1]&@l,If[#===i,0,1]&@m,If[#===i,0,1]&@n])(Subscript[y, k])(Subscript[x, l])(Subscript[y, m])(Subscript[x, n]),{k,{i,j}},{l,{i,j}},{m,{i,j}},{n,{i,j}}])+((O[ϵ])^3)]/.{(Subscript[r, 1,0])->0,(Subscript[r, 1,1])->1,(Subscript[r, 0,0])->-1,(Subscript[r, 0,1])->0,(Subscript[s, 0,0,0,0])->(1/2),(Subscript[s, 1,0,1,0])->0,(Subscript[s, 1,0,0,0])->1,(Subscript[s, 0,0,1,0])->-1,(Subscript[s, 1,1,1,1])->(1/2),(Subscript[s, 1,1,1,0])->1,(Subscript[s, 1,0,1,1])->-1,(Subscript[s, 0,0,1,1])->1,(Subscript[s, 0,1,0,1])->1,(Subscript[s, 0,1,1,0])->-1,(Subscript[s, 1,0,0,1])->1,(Subscript[s, 1,1,0,0])->-1,(Subscript[s, 0,0,0,1])->-1,(Subscript[s, 0,1,0,0])->-1,(Subscript[s, 0,1,1,1])->1,(Subscript[s, 1,1,0,1])->((-1)/2)}

“Define” Code

Define[lhs=rhs, ...] defines the lhs to be rhs, except that rhs is computed only once for each value of $k. Fancy Mathematica not for the faint of heart. Most readers should ignore.

SetAttributes[Define, HoldAll];
Define[def_,defs__] := (Define[def]; Define[defs];);
Define[(Subscript[op_, is__])=ℰ_] := Module[{SD,ii,jj,kk,isp,nis,nisp,sis},Block[{i,j,k},
ReleaseHold[Hold[
SD[(Subscript[op, nisp,$k_Integer]),Block[{i,j,k},(Subscript[op, isp,$k])=ℰ;(Subscript[op, nis,$k])]];
SD[(Subscript[op, isp]),(Subscript[op, {is},$k])]; SD[(Subscript[op, sis__]),(Subscript[op, {sis}])];
]/. {SD->SetDelayed,
isp->{is}/.{i->i_,j->j_,k->k_},
nis->{is}/.{i->ii,j->jj,k->kk},
nisp->{is}/.{i->ii_,j->jj_,k->kk_}
}]  ]]

Define[(Subscript[m, i,j->k])=(Subscript[𝔼, {i,j}->{k}])[0,-(Subscript[ξ, i])(Subscript[η, j])+((Subscript[η, i])+(Subscript[η, j]))(Subscript[y, k])+((Subscript[ξ, i])+(Subscript[ξ, j]))(Subscript[x, k]),1]](*Heisenberg multiplication*)

AllMonomials[{},0]={1};
AllMonomials[{},d_Integer] /; d>0 := {};
AllMonomials[{v_,vs___},d_Integer] := Join@@Table[(v^(d-k))AllMonomials[{vs},k],{k,0,d}];
AllMonomials[vs_List, {d_}] := Join@@Table[AllMonomials[vs,k],{k,0,d}];

Basis[js_List,m_]:=Flatten@Outer[Times,AllMonomials[Table[(Subscript[y, j]),{j,js}],m],AllMonomials[Table[(Subscript[x, j]),{j,js}],m]];
Basis[js_List,{m_}]:=Flatten@Table[Basis[js,k],{k,1,m}]

Basis[{i,j},{2}]

GenericCombination[bas_,c_]:=bas.Table[(Subscript[c, j]),{j,Length@bas}]

GenericCombination[Basis[{i,j},{2}],c]

The docile R-matrix and its inverse

Once[DRules={};]

(Subscript[R, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[0,((Subscript[y, i])-(Subscript[y, j]))(T-1) (Subscript[x, j]),1+ϵ GenericCombination[Basis[{i,j},{2}],c]+((O[ϵ])^2)]/.DRules
(Subscript[(OverBar[R]), i_,j_]):=(Subscript[𝔼, {}->{i,j}])[0,((Subscript[y, i])-(Subscript[y, j]))((T^(-1))-1) (Subscript[x, j]),1+ϵ GenericCombination[Basis[{i,j},{2}],d]+((O[ϵ])^2)]/.DRules
(Subscript[CC, i_]):=(Subscript[𝔼, {}->{i}])[0,0,(Sqrt[T])+(α+β (Subscript[x, i])(Subscript[y, i])+γ (Subscript[x, i]^2)(Subscript[y, i]^2))ϵ+((O[ϵ])^2)]/.DRules
(Subscript[(OverBar[CC]), i_]):=(Subscript[𝔼, {}->{i}])[0,0,((((Sqrt[T])))^(-1))+(αi+βi (Subscript[x, i])(Subscript[y, i])+γi (Subscript[x, i]^2)(Subscript[y, i]^2))ϵ+((O[ϵ])^2)]/.DRules
(Subscript[Kink, i_]):=(Subscript[CC, 3])(Subscript[R, 1,2])//(Subscript[m, 2,3->2])//(Subscript[m, 2,1->i])
(Subscript[(OverBar[Kink]), i_]):=(Subscript[CC, 3])(Subscript[(OverBar[R]), 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->i])

Requirements on R and CC to nail them down

((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))≡((Subscript[R, 2,3])(Subscript[R, 4,5])(Subscript[R, 1,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))
((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))
(Subscript[CC, 1])(Subscript[(OverBar[CC]), 2])//(Subscript[m, 1,2->1]) 
(Subscript[Kink, 1])≡((Subscript[(OverBar[CC]), 3])(Subscript[R, 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->1]))

eqns=Join[
Thread[CoefficientRules[Coefficient[((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))[[3]]-((Subscript[R, 2,3])(Subscript[R, 4,5])(Subscript[R, 1,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))[[3]]//Normal,ϵ],{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])}][[;;,2]]==0],
Thread[CoefficientRules[Coefficient[((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))[[3]]//Normal,ϵ],{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[y, 1]),(Subscript[y, 2])}][[;;,2]]==0],
Thread[CoefficientRules[Coefficient[((Subscript[CC, 1])(Subscript[(OverBar[CC]), 2])//(Subscript[m, 1,2->1]))[[3]]//Normal,ϵ],{(Subscript[x, 1]),(Subscript[y, 1])}][[;;,2]]==0],
Thread[CoefficientRules[Coefficient[((Subscript[Kink, 1]))[[3]]-((Subscript[(OverBar[CC]), 3])(Subscript[R, 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->1]))[[3]]//Normal,ϵ],{(Subscript[x, 1]),(Subscript[y, 1])}][[;;,2]]==0]
]

Solve[eqns,{α,β,γ,αi,βi,γi}⋃Table[(Subscript[c, j]),{j,13}]⋃Table[(Subscript[d, j]),{j,13}]]

{DRules}=Solve[eqns,{α,β,γ,αi,βi,γi}⋃Table[(Subscript[c, j]),{j,13}]⋃Table[(Subscript[d, j]),{j,13}]]

{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[CC, 1]),(Subscript[(OverBar[CC]), 1])}

((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))≡((Subscript[R, 2,3])(Subscript[R, 4,5])(Subscript[R, 1,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))
((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))
(Subscript[CC, 1])(Subscript[(OverBar[CC]), 2])//(Subscript[m, 1,2->1]) 
(Subscript[Kink, 1])≡((Subscript[(OverBar[CC]), 3])(Subscript[R, 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->1]))

OC fails

((Subscript[R, 1,2])(Subscript[R, 4,3])//(Subscript[m, 1,4->1]))≡((Subscript[R, 1,3])(Subscript[R, 4,2])//(Subscript[m, 1,4->1]))//Simplify

R2 braid-like

(Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2])
(Subscript[(OverBar[R]), 1,2])(Subscript[R, 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2])

‘naked’ R2 cyclic (!!):

(Subscript[R, 3,2])(Subscript[(OverBar[R]), 1,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2])
(Subscript[R, 1,4])(Subscript[(OverBar[R]), 3,2])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2])

Proper R2 cyclic:

((Subscript[CC, 3])(Subscript[R, 5,2])(Subscript[(OverBar[R]), 1,4])//(Subscript[m, 1,3->1])//(Subscript[m, 1,5->1])//(Subscript[m, 2,4->2]))≡(Subscript[CC, 1])(Subscript[𝔼, {}->{2}])[0,0,1+((O[ϵ])^2)]
((Subscript[(OverBar[CC]), 4])(Subscript[R, 1,6])(Subscript[(OverBar[R]), 3,2])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2])//(Subscript[m, 2,6->2]))≡(Subscript[(OverBar[CC]), 2])(Subscript[𝔼, {}->{1}])[0,0,1+((O[ϵ])^2)]

R3:

((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))≡((Subscript[R, 2,3])(Subscript[R, 4,5])(Subscript[R, 1,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))

Pairwise equality of the four kinks:

(Subscript[Kink, 1])≡((Subscript[(OverBar[CC]), 3])(Subscript[R, 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->1]))
(Subscript[(OverBar[Kink]), 1])≡((Subscript[(OverBar[CC]), 3])(Subscript[(OverBar[R]), 1,2])//(Subscript[m, 2,3->2])//(Subscript[m, 2,1->1]))

Trefoils?:

(Subscript[(OverBar[Kink]), 8])(Subscript[(OverBar[Kink]), 9])(Subscript[(OverBar[Kink]), 10])(Subscript[(OverBar[CC]), 7])(Subscript[R, 1,4])(Subscript[R, 5,2])(Subscript[R, 3,6])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1])//(Subscript[m, 1,7->1])//(Subscript[m, 1,4->1])//(Subscript[m, 1,5->1])//(Subscript[m, 1,6->1])//(Subscript[m, 1,8->1])//(Subscript[m, 1,9->1])//(Subscript[m, 1,10->1])
(Subscript[(OverBar[Kink]), 8])(Subscript[(OverBar[Kink]), 9])(Subscript[(OverBar[Kink]), 10])(Subscript[CC, 7])(Subscript[R, 4,1])(Subscript[R, 2,5])(Subscript[R, 6,3])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1])//(Subscript[m, 1,7->1])//(Subscript[m, 1,4->1])//(Subscript[m, 1,5->1])//(Subscript[m, 1,6->1])//(Subscript[m, 1,8->1])//(Subscript[m, 1,9->1])//(Subscript[m, 1,10->1])

Unfortunately? This docile invariant does not see the difference between the mirror trefoils. Perhaps it is actually determined by Alexander.

(Subscript[Kink, 8])(Subscript[Kink, 9])(Subscript[Kink, 10])(Subscript[CC, 4])(Subscript[(OverBar[R]), 1,5])(Subscript[(OverBar[R]), 6,2])(Subscript[(OverBar[R]), 3,7])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1])//(Subscript[m, 1,4->1])//(Subscript[m, 1,5->1])//(Subscript[m, 1,6->1])//(Subscript[m, 1,7->1])//(Subscript[m, 1,8->1])//(Subscript[m, 1,9->1])//(Subscript[m, 1,10->1])

RVK[pd_PD]:=Module[{n,xs,x,rots,front={0},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=0,k<2n,++k,If[k==0∨FreeQ[front,-k],
front=Flatten[front/.k->(xs/.{
Xp[k+1,l_]|Xm[l_,k+1]:>{l,k+1,1-l},
Xp[l_,k+1]|Xm[k+1,l_]:>(++rots[[l]];{1-l,k+1,l})
})],
Cases[front,k|-k]/.{k,-k}:>--rots[[k+1]];
]];
RVK[xs,rots] ];
RVK[K_]:=RVK[PD[K]];

rot[i_,0]:=(Subscript[𝔼, {}->{i}])[0,0,1];
rot[i_,n_]:=Module[{j},
rot[i,n]=If[n>0,rot[i,n-1](Subscript[CC, j]),rot[i,n+1](Subscript[(OverBar[CC]), j])]//(Subscript[m, i,j->i])];

Z[K_] := Z[RVK@K];
Z[rvk_RVK] := (*Z[rvk] =*)Module[{todo,n,rots,ζ,done,st,cx, ζ1, i,j,k,k1,k2,k3},
{todo,rots}=List@@rvk;
AppendTo[rots,0];
n=Length[todo];
ζ=(Subscript[𝔼, {}->{0}])[0,0,1];
done={0};
st=Range[0,2n+1];
While[{}=!=($M=todo),
{cx}=MaximalBy[todo, Length[done⋂{#[[1]], #[[2]], #[[1]]-1,#[[2]]-1}]&,1];
{i,j}=List@@cx;
ζ1=Switch[Head[cx],
 Xp, ((Subscript[R, i,j])(Subscript[(OverBar[Kink]), k]))//(Subscript[m, j,k->j]),
 Xm, ((Subscript[(OverBar[R]), i,j])(Subscript[Kink, k]))//(Subscript[m, j,k->j])
];
ζ1=(rot[k,rots[[i]]]ζ1)//(Subscript[m, k,i->i]); rots[[i]]=0;
ζ1=(ζ1 rot[k, rots[[i+1]]])//(Subscript[m, i,k->i]); rots[[i+1]]=0;
ζ1=(rot[k,rots[[j]]]ζ1)//(Subscript[m, k,j->j]); rots[[j]]=0;
ζ1=(ζ1 rot[k, rots[[j+1]]])//(Subscript[m, j,k->j]); rots[[j+1]]=0;
ζ*=ζ1;
If[MemberQ[done, i], ζ=ζ//(Subscript[m, i,i+1->i]); st=st/.st[[i+2]]->st[[i+1]]];
If[MemberQ[done, i-1],  ζ=ζ//(Subscript[m, st[[i]],i->st[[i]]]); st=st/.st[[i+1]]->st[[i]]]; 
If[MemberQ[done, j],  ζ=ζ//(Subscript[m, j,j+1->j]); st=st/.st[[j+2]]->st[[j+1]]]; 
If[MemberQ[done, j-1],  ζ=ζ//(Subscript[m, st[[j]],j->st[[j]]]); st=st/.st[[j+1]]->st[[j]]];
done=done⋃{i-1,i,j-1,j};
todo=DeleteCases[todo, cx]
];
CF/@ (ζ (*/. {(Subscript[x, 0])->x,(Subscript[y, 0])->y,(Subscript[a, 0])->a}*))
]

NewBit[K_]:=Module[{Alex=Alexander[K][T]},
(T^3)((Alex^3)/(T-1))Coefficient[Z[K][[3]],ϵ]//Factor]

NewBit/@AllKnots[{3,5}]

(*Two knots with equal Alexander, new bit does not agree*)
Alexander[Knot[6,1]]==Alexander[Knot[9,46]]
eq=(NewBit[Knot[6,1]]==NewBit[Knot[9,46]]);
eq/.(Subscript[c, 9])->0
eq/.(Subscript[c, 2])->0

Factor[NewBit/@AllKnots[{3,7}] /. (Subscript[c, 2])->0]

(Subscript[Kink, 1])

(Subscript[CC, 1])