Pensieve header:  Time 9013.55. “ReplaceAll” removed from CF.

Date[]

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\BabyDoPeGDO"];
Once[<<KnotTheory`];
Once[Get@"../Profile/Profile.m"];
<<Objects.m
<<KT.m

Engine

CCF[ℰ_] := (Subscript[PP, CCF])@ExpandDenominator@ExpandNumerator@Together[ℰ]; (*CoefficientCanonical Form *)
CF[ℰ_List]:=CF/@ℰ;
CF[ℰ_ϵSeries]:=CF/@ℰ;
CF[ℰ_] := (Subscript[PP, CF])@Module[
{vs=Cases[ℰ,(Subscript[(y|x|η|ξ), _]),∞]⋃{y|x|η|ξ}},
Total[(CCF[#[[2]]](Times@@(vs^(#[[1]]))))& /@ CoefficientRules[Expand[ℰ], vs]]
];
(*CF[ℰ_] := (Subscript[PP, CF])@CCF[ℰ];*)
CF[ℰ_𝔼]:=CF/@ℰ; 
CF[(Subscript[𝔼, sp___])[ℰs___]]:=CF/@(Subscript[𝔼, sp])[ℰs];

ϵSeries/: S1_ϵSeries≡S2_ϵSeries:=Length[S1]==Length[S2]∧Inner[CF[#1]==CF[#2]&,S1,S2,And];
ϵSeries[0]:=ϵSeries@@Table[0,$k+1];
ϵSeries/: S1_ϵSeries+S2_ϵSeries := ϵSeries@@Table[S1[[k]]+S2[[k]],{k,Min[Length@S1,Length@S2]}];
ϵSeries/: S1_ϵSeries*S2_ϵSeries := ϵSeries@@Table[Sum[S1[[j+1]]*S2[[k-j+1]], {j,0,k}],{k,0,Min[Length@S1,Length@S2]-1}];
ϵSeries /:c_*S_ϵSeries:=(c#)& /@ S;
ϵSeries/:(∂_(vs___))S_ϵSeries:=(s|->(∂_vs)s)/@S;

The Main Program

Variables and their duals:

{(SuperStar[y]),(SuperStar[x]),(SuperStar[η]),(SuperStar[ξ])}={η,ξ,y,x}; 
(SuperStar[(vs_List)]):=(v|->(SuperStar[v]))/@vs;
(SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]);

𝔼 operations:

𝔼/:𝔼[ω1_,Q1_,P1_]≡𝔼[ω2_,Q2_,P2_]:=CF[ω1==ω2]∧CF[Q1==Q2]∧(P1≡P2);
𝔼/:𝔼[ω1_,Q1_,P1_]𝔼[ω2_,Q2_,P2_]:=𝔼[ω1 ω2,Q1+Q2,P1+P2];
(Subscript[𝔼, d1_->r1_])[ℰ1s___]≡(Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (d1==d2)∧(r1==r2)∧(𝔼[ℰ1s]≡𝔼[ℰ2s]);
(Subscript[𝔼, d1_->r1_])[ℰ1s___](Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (Subscript[𝔼, (d1⋃d2)->(r1⋃r2)])@@(𝔼[ℰ1s]𝔼[ℰ2s]);
(Subscript[(Subscript[𝔼, dr_])[ℰs___], $k_]):=(Subscript[𝔼, dr])@@(Subscript[𝔼[ℰs], $k]);

(Subscript[𝔼, d1_->r1_])[ℰ1s___]//(Subscript[𝔼, d2_->r2_])[ℰ2s___] :=Module[{is=r1⋂d2,lvs},
lvs=Flatten@Table[{(Subscript[x, $@i]),(Subscript[y, $@i])},{i,is}];
(Subscript[𝔼, (d1⋃Complement[d2,is])->(r2⋃Complement[r1,is])])@@((Subscript[Zip, lvs⋃(SuperStar[lvs])])[(SuperStar[lvs]).lvs,Times[
𝔼[ℰ1s]/.Table[(Subscript[(v:x|y), i])->(Subscript[v, $@i]),{i,is}],
𝔼[ℰ2s]/.Table[(Subscript[(v:ξ|η), i])->(Subscript[v, $@i]),{i,is}]
]])
]

(Subscript[Zip, vs_])[ℱ_,ℰ_]:=⟨ℱ,ℰ⟩//(Subscript[Zip1, vs])//(Subscript[Zip2, vs])//(Subscript[Zip3, vs]);
(Subscript[Zip, vs_])[ℱ_,ℰ_]:=⟨ℱ,ℰ⟩//(Subscript[Zip1, vs])//(Subscript[EZip23, vs]);

Getting rid of the quadratic.

(Subscript[Zip1, {}])=Identity;
(Subscript[Zip1, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := (Subscript[PP, Zip1])@Module[{ℐ,F,G,u,v},
ℐ=IdentityMatrix@Length@vs;
F=Table[(∂_(u,v))ℱ,{u,(SuperStar[vs])},{v,(SuperStar[vs])}];
G=Table[(∂_(u,v))Q,{u,vs},{v,vs}];
⟨CF[(SuperStar[vs]).F.Inverse[ℐ-G.F].(SuperStar[vs])/2], 𝔼[CF@PowerExpand@Factor[ω  ((Det[ℐ- G.F])^(-1/2))],CF[Q-vs.G.vs/2],P]⟩
]

Getting rid of linear terms.

(Subscript[Zip2, {}])=Identity;
(Subscript[Zip2, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := (Subscript[PP, Zip2])@Module[{F,Y,u,v},
F=Table[(∂_(u,v))ℱ,{u,(SuperStar[vs])},{v,(SuperStar[vs])}];
Y=Table[(∂_v)Q,{v,vs}];
CF/@⟨ℱ, 𝔼[ω,Q-Y.vs+Y.F.Y/2, P/.Thread[vs->vs+F.Y]]⟩
]

Dealing with Feynman diagrams.

Note that the power m of λ is at most k-1+((2k+2)/2)=2k. We write (Subscript[Z, λ])=∑Z[m](λ^m).

(Subscript[Zip3, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := (Subscript[PP, Zip3])@Module[{Z,u,v,m,j},
Z[0]=P;
For[m=0,m<2$k,++m,
Z[m+1]=CF[(1/(2(m+1)))Sum[(∂_((SuperStar[u]),(SuperStar[v])))ℱ((∂_(u,v))Z[m]+Sum[((∂_u)Z[j])((∂_v)Z[m-j]),{j,0,m}]),{u,vs},{v,vs}]]
];
𝔼[ω,Q,CF[Sum[Z[m],{m,0,2$k}]/.Table[v->0,{v,vs}]]]
]

(Subscript[EZip23, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := (Subscript[PP, EZip23])@Module[
{nP,nℱ,nQ,j=0,ps,c,t,rr={(*release rules*)}},
nP=Total[
CoefficientRules[#, vs] /. (ps_->c_) :> (AppendTo[rr,t[++j]->CF@c]; t[j](Times@@(vs^ps)))
]& /@ P;
nQ=Total[CoefficientRules[Q, vs] /. (ps_->c_) :> (AppendTo[rr,t[++j]->CF@c]; t[j](Times@@(vs^ps)))];
nℱ=Total[CoefficientRules[ℱ, (SuperStar[vs])] /. (ps_->c_) :> (AppendTo[rr,t[++j]->CF@c]; t[j](Times@@((((SuperStar[vs])))^ps)))];
CF[Expand[⟨nℱ,𝔼[ω,nQ,nP]⟩//(Subscript[Zip2, vs])//(Subscript[Zip3, vs])]/.rr]
]

Profile

BeginProfile[];
PopupWindow[Button["Show Profile Monitor"],Dynamic[PrintProfile[], UpdateInterval->3, TrackedSymbols->{}]]

$k=1

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

$k=1; NewBit/@AllKnots[{3,5}]

(*Two knots with equal Alexander, new bit does not agree*)
Alexander[Knot[6,1]]==Alexander[Knot[9,46]]
$k=1; Timing[NewBit[Knot[6,1]]==NewBit[Knot[9,46]]]

PrintProfile[]

$k=1; equiv={Knot[10,106],Knot[12,NonAlternating,369]};
Length@Union[Z/@equiv]

$k=1; equiv={Knot[12,Alternating,427],Knot[12,Alternating,435],Knot[12,Alternating,990]};
Length@Union[Z/@equiv]

PrintProfile[]

$k=2

$k=2; equiv={Knot[10,106],Knot[12,NonAlternating,369]};
Length@Union[Z/@equiv]

PrintProfile[]

$k=2; equiv={Knot[12,Alternating,427],Knot[12,Alternating,435],Knot[12,Alternating,990]};
Length@Union[Z/@equiv]

PrintProfile[]

Date[]

$k=2; equiv={Knot[12,NonAlternating,60],Knot[12,NonAlternating,61],Knot[12,NonAlternating,219]};
Length@Union[Z/@equiv]

PrintProfile[]

Date[]