Pensieve header:  Perturbing the Heisenberg-algebra knot invariant. Continues “Solving to $k=3.nb” at pensieve://Projects/BabyDoPeGDO/.

𝔼[ω,Q,P_ϵSeries] represents ω (e^(Q+P)), where ω is a scalar, Q is an ϵ-free quadratic, and P=(∑_(k=0)^$k)P[[k]](ϵ^k) is a perturbation (it is ill-advised to include ω in P because then it will have log terms).

Scheme: (Subscript[𝔼, _])[_]//(Subscript[𝔼, _])[_] calls FZip or Zip, which are functionally the same. Zip works by handling the quadratic part and calling PZip for the perturbation-only part. PZip works by iteratively solving the synthesis equation. FZip works by encapsulating coefficients, calling Zip, and back-substituting.

Initialization and minor utilities

SetDirectory["C:\\drorbn\\AcademicPensieve\\Classes\\21-1350-KnotTheory\\Preps"];
Once[<<"../Common.m"];

$k=1;

CCF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[ℰ];
CF[ℰ_List]:=CF/@ℰ;
CF[ℰ_ϵSeries]:=CF/@ℰ;
CF[ℰ_] :=Module[
{vs=Cases[ℰ,(Subscript[(p|x|π|ξ), _]),∞]⋃{p|x|π|ξ}},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))]
];
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[p]),(SuperStar[x]),(SuperStar[π]),(SuperStar[ξ])}={π,ξ,p,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[p, $@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|p), 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])

Getting rid of the quadratic.

(Subscript[Zip1, {}])=Identity;
(Subscript[Zip1, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := 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, 𝔼[PowerExpand@Factor[ω  ((Det[ℐ- G.F])^(-1/2))],Q-vs.G.vs/2,P]⟩
]

Getting rid of linear terms.

(Subscript[Zip2, {}])=Identity;
(Subscript[Zip2, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := 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) and then
(m+1)(∂_λ)Z[m+1]=(1/2)(Subscript[F, uv])((∂_u)(∂_v)Z[m]+(∑_j)((∂_u)Z[j])((∂_v)Z[m-j])).

(Subscript[Zip3, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := 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}]]]
]

Note that the condition (Subscript[deg, (Subscript[z, B])])(Subscript[Z, λ])<=4(Subscript[deg, ϵ])(Subscript[Z, λ])-2(Subscript[deg, λ])(Subscript[Z, λ]) is preserved under the above iteration, so if the initial P satisfies (Subscript[deg, (Subscript[z, B])])P<=4(Subscript[deg, ϵ])P, we only need to sum up to Z[2$k]. Note also that if P is “docile”, (Subscript[deg, (Subscript[z, all])])P<2(Subscript[deg, ϵ])P+2, then so is (Subscript[Z, λ]).

The Basic Tensors

(Subscript[η, i_]):=(Subscript[𝔼, {}->{i}])[1,0,ϵSeries[0]];
(Subscript[m, i_,j_->k_]):=(Subscript[𝔼, {i,j}->{k}])[1,-(Subscript[ξ, i])(Subscript[π, j])+((Subscript[π, i])+(Subscript[π, j]))(Subscript[p, k])+((Subscript[ξ, i])+(Subscript[ξ, j]))(Subscript[x, k]),ϵSeries[0]]

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[p, j]),{j,js}],m],AllMonomials[Table[(Subscript[x, j]),{j,js}],m]];
Basis[js_List,{m_}]:=Flatten@Table[Basis[js,k],{k,0,m}]

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

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

GenericCombination[Basis[{i,j},{2}],(Subscript[c, 1])]

(Subscript[R, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[(T^(1/2)),(T-1)((Subscript[p, i])-(Subscript[p, j])) (Subscript[x, j]) ,ϵSeries@@Prepend[0]@Table[GenericCombination[Basis[{i,j},{k+1}],(Subscript[c, k])],{k,$k}]];
(Subscript[(OverBar[R]), i_,j_]):=(Subscript[𝔼, {}->{i,j}])[(T^(-1/2)),((T^(-1))-1)((Subscript[p, i])-(Subscript[p, j])) (Subscript[x, j]),ϵSeries@@Prepend[0]@Table[GenericCombination[Basis[{i,j},{k+1}],(Subscript[d, k])],{k,$k}]];
(Subscript[C, i_]):=(Subscript[𝔼, {}->{i}])[(T^(1/2)),0,ϵSeries@@Prepend[0]@Table[GenericCombination[Basis[{i},{k+1}],(Subscript[e, k])],{k,$k}]];
(Subscript[(OverBar[C]), i_]):=(Subscript[𝔼, {}->{i}])[(T^(-1/2)),0,ϵSeries@@Prepend[0]@Table[GenericCombination[Basis[{i},{k+1}],(Subscript[f, k])],{k,$k}]];

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

RMoves:={
((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[η, 1])(Subscript[η, 2])),
((Subscript[C, 1])(Subscript[(OverBar[C]), 2])//(Subscript[m, 1,2->1]) )≡(Subscript[η, 1]),
((Subscript[R, 1,4])(Subscript[(OverBar[R]), 5,2])(Subscript[(OverBar[C]), 3])//(Subscript[m, 2,4->2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,5->1]))≡(Subscript[(OverBar[C]), 1])(Subscript[η, 2]),
((Subscript[C, 3])(Subscript[R, 1,2])//(Subscript[m, 2,3->2])//(Subscript[m, 2,1->1]))≡((Subscript[(OverBar[C]), 3])(Subscript[R, 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->1])),
((Subscript[(OverBar[C]), 2])(Subscript[R, 1,3])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))≡(Subscript[η, 1]), ((Subscript[(OverBar[C]), 2])(Subscript[(OverBar[R]), 3,1])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))≡(Subscript[η, 1]),
((Subscript[C, 2])(Subscript[(OverBar[R]), 1,3])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))≡(Subscript[η, 1]),((Subscript[C, 2])(Subscript[R, 3,1])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))≡(Subscript[η, 1])
}

Solving for R, C, $k=1

$k=1;
{(Subscript[R, 1,2]),(Subscript[C, 1])}
unknowns=Cases[{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])},(Subscript[(c|d|e|f), $k,_]),∞]//Union

Short[errors=CCF/@Cases[RMoves,  a_==b_ :> a-b], 25]

eqns=Thread[0==Union@@(CoefficientRules[#,{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[p, 1]),(Subscript[p, 2]),(Subscript[p, 3])}][[;;,2]]& /@ errors)]

{sol}=Solve[eqns,unknowns]

sol/.(a_->b_):>(a=b)

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

Cases[{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])},(Subscript[(c|d|e|f), $k,_]),∞]//Union

{(Subscript[c, 1,2])=0,(Subscript[c, 1,5])=0,(Subscript[c, 1,7])=0,(Subscript[c, 1,10])=1};
{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])}

RMoves

Some Knot Theory at $k=1

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

NewBit/@AllKnots[{3,5}]

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

equiv={Knot[10,106],Knot[12,NonAlternating,369]};
Length@Union@Echo[ZF/@equiv]

equiv={Knot[12,Alternating,427],Knot[12,Alternating,435],Knot[12,Alternating,990]};
Length@Union[ZF/@equiv]

Solving for R, C, $k=2

$k=2;
{(Subscript[R, 1,2]),(Subscript[C, 1])}
Short[RMoves,20]

unknowns=Cases[{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])},(Subscript[(c|d|e|f), $k,_]),∞]//Union

Short[errors=CCF/@Cases[RMoves,  a_==b_ :> a-b], 25]

Short[#,10]&[eqns=Thread[0==Union@@(CoefficientRules[#,{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[p, 1]),(Subscript[p, 2]),(Subscript[p, 3])}][[;;,2]]& /@ errors)]]

{sol}=Solve[eqns,unknowns]

sol/.(a_->b_):>(a=b)

Cases[{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])},(Subscript[(c|d|e|f), $k,_]),∞]//Union

{(Subscript[c, 2,2])=0,(Subscript[c, 2,5])=0,(Subscript[c, 2,7])=0,(Subscript[c, 2,10])=0,(Subscript[c, 2,16])=0};
{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])}

RMoves

Some Knot Theory at $k=2

According to 12XingStats.nb at pensieve://Projects/SL2Invariant/k=2/ the following pair have equal (Subscript[ρ, 1]) but different (Subscript[ρ, 2]):

equiv={Knot[10,106],Knot[12,NonAlternating,369]};
res21=ZF/@equiv
Simplify[res21[[1]]≡res21[[2]]]

According to 12XingStats.nb at pensieve://Projects/SL2Invariant/k=2/ the following triple have equal (Subscript[ρ, 1]) but different (Subscript[ρ, 2]):

equiv={Knot[12,Alternating,427],Knot[12,Alternating,435],Knot[12,Alternating,990]};
Length@Union[res22=ZF/@equiv]

Solving for R, C, $k=3

$k=3;
Short[RMoves,20]

unknowns=Cases[{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])},(Subscript[(c|d|e|f), $k,_]),∞]//Union

Short[errors=CCF/@Cases[RMoves,  a_==b_ :> a-b], 25]

Short[#,10]&[eqns=Thread[0==Union@@(CoefficientRules[#,{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[p, 1]),(Subscript[p, 2]),(Subscript[p, 3])}][[;;,2]]& /@ errors)]]

{sol}=Solve[eqns,unknowns]

sol/.(a_->b_):>(a=b)

Cases[{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])},(Subscript[(c|d|e|f), $k,_]),∞]//Union

{(Subscript[c, 3,2])=0,(Subscript[c, 3,5])=0,(Subscript[c, 3,7])=0,(Subscript[c, 3,10])=0,(Subscript[c, 3,16])=0,(Subscript[c, 3,32])=1};
{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2]),(Subscript[C, 1]),(Subscript[(OverBar[C]), 1])}

RMoves