Pensieve header:  Finding the A2 $d=1$ invariant using undetermined coefficients.

Searching for Q+xxx+ϵ(ppp+1+px+ppxx) solutions.

Initialization

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\HigherRank"];
Once[<<KnotTheory`; <<Rot.m];
<< FormalGaussianIntegration.m;
(SuperPlus[i_]):=i+1;

Features[Knot[8,17]]

(Subscript[T, 3])=(Subscript[T, 1]^(-1))(Subscript[T, 2]^(-1));
𝒮={(Subscript[x, __]),(Subscript[p, __])};
q[s_,i_,j_]:=Sum[
(Subscript[x, ν,i]) ((Subscript[p, ν,(SuperPlus[i])])-(Subscript[p, ν,i]))+(Subscript[x, ν,j]) ((Subscript[p, ν,(SuperPlus[j])])-(Subscript[p, ν,j]))+((Subscript[T, ν]^s)-1)(Subscript[x, ν,i])((Subscript[p, ν,(SuperPlus[i])])-(Subscript[p, ν,(SuperPlus[j])])),
{ν,3}];
ℒ[(Subscript[X, i_,j_])[s_]]:=(Subscript[T, 3]^s)𝔼[q[s,i,j]+(B^(-1))(Subscript[r, 0])[s,i,j]+ϵ B (Subscript[r, 1])[s,i,j]+ϵ (Subscript[r, 42])[s,i,j]+((O[ϵ])^2)];
(*(Subscript[γ, 1])[φ_,k_]:=φ(3/2-(Subscript[x, 1,k])(Subscript[p, 1,k])-(Subscript[x, 2,k])(Subscript[p, 2,k])-(Subscript[x, 3,k])(Subscript[p, 3,k]));*)
ℒ[(Subscript[C, k_])[0]]:=𝔼[Sum[(Subscript[x, ν,k])((Subscript[p, ν,(SuperPlus[k])])-(Subscript[p, ν,k])),{ν,3}]+((O[ϵ])^2) ];
ℒ[(Subscript[C, k_])[φ_]]:=(Subscript[T, 3]^φ)𝔼[Sum[(Subscript[x, ν,k])((Subscript[p, ν,(SuperPlus[k])])-(Subscript[p, ν,k])),{ν,3}]+(B^(-1))(Subscript[γ, 0])[φ,k]+ϵ B (Subscript[γ, 1])[φ,k]+ϵ (Subscript[γ, 42])[φ,k]+((O[ϵ])^2) ];
(Subscript[ps, i_]):=Sequence[(Subscript[p, 1,i]),(Subscript[p, 2,i]),(Subscript[p, 3,i])];
(Subscript[xs, i_]):=Sequence[(Subscript[x, 1,i]),(Subscript[x, 2,i]),(Subscript[x, 3,i])];
(Subscript[vs, i_]):=Sequence[(Subscript[ps, i]),(Subscript[xs, i])];
ℱ[is___]:=𝔼[Sum[(Subscript[π, ν,i])(Subscript[p, ν,i]),{i,{is}}, {ν,3}]];
ℒ[K_]:=CF[ℒ/@Features[K][[2]]];
vs[K_] := Union@@Table[{(Subscript[vs, i])},{i,Features[K][[1]]}]

(Subscript[vs, i])

The Various Terms

The xxx Terms ((Subscript[r, 0]))

κ=0;
(Subscript[r, 0])[1,i_,j_]:=Evaluate[Sum[
(Subscript[a, ++κ])(Subscript[x, 3,k3])(Subscript[x, 1,k1])(Subscript[x, 2,k2]),
{k1,{i,j}},{k2,{i,j}},{k3,{i,j}}
]];
(Subscript[r, 0])[1,i,j]

κ=0;
(Subscript[r, 0])[-1,i_,j_]:=Evaluate[Sum[
(Subscript[d, ++κ])(Subscript[x, 3,k3])(Subscript[x, 1,k1])(Subscript[x, 2,k2]),
{k1,{i,j}},{k2,{i,j}},{k3,{i,j}}
]];
(Subscript[r, 0])[-1,i,j]

The ppp Terms ((Subscript[r, 1]))

κ=0;
(Subscript[r, 1])[1,i_,j_]:=Evaluate[Sum[
(Subscript[b, ++κ])(Subscript[p, 3,k3])(Subscript[p, 1,k1])(Subscript[p, 2,k2]),
{k1,{i,j}},{k2,{i,j}},{k3,{i,j}}
]];
(Subscript[r, 1])[1,i,j]

κ=0;
(Subscript[r, 1])[-1,i_,j_]:=Evaluate[Sum[
(Subscript[e, ++κ])(Subscript[p, 3,k3])(Subscript[p, 1,k1])(Subscript[p, 2,k2]),
{k1,{i,j}},{k2,{i,j}},{k3,{i,j}}
]];
(Subscript[r, 1])[-1,i,j]

The ppxx Terms ((Subscript[r, 42]))

κ=0;
Short[(Subscript[r, 42])[1,i_,j_]=Evaluate[Plus[
Sum[
(Subscript[c, ++κ])(Subscript[x, ν1,k1])(Subscript[p, ν1,k2])(Subscript[x, ν2,k3])(Subscript[p, ν2,k4]),
{k1,{i,j}},{k2,{i,j}},{k3,{i,j}},{k4,{i,j}},{ν1,2},{ν2,ν1,3}
],
Sum[
(Subscript[c, ++κ])(Subscript[x, ν,k1])(Subscript[p, ν,k2]),
{k1,{i,j}},{k2,{i,j}},{ν,3}
],
(Subscript[c, ++κ])
]]]

κ=0;
Short[(Subscript[r, 42])[-1,i_,j_]=Evaluate[Plus[
Sum[
(Subscript[f, ++κ])(Subscript[x, ν1,k1])(Subscript[p, ν1,k2])(Subscript[x, ν2,k3])(Subscript[p, ν2,k4]),
{k1,{i,j}},{k2,{i,j}},{k3,{i,j}},{k4,{i,j}},{ν1,2},{ν2,ν1,3}
],
Sum[
(Subscript[f, ++κ])(Subscript[x, ν,k1])(Subscript[p, ν,k2]),
{k1,{i,j}},{k2,{i,j}},{ν,3}
],
(Subscript[f, ++κ])
]]]

The γ Terms ((Subscript[γ, 0]), (Subscript[γ, 1]),(Subscript[γ, 42]))

κ=0;
(Subscript[γ, 0])[1,k_]:=Evaluate[(Subscript[g, ++κ])(Subscript[p, 3,k])(Subscript[x, 1,k])(Subscript[x, 2,k])];
(Subscript[γ, 1])[1,k_]:=Evaluate[(Subscript[g, ++κ])(Subscript[x, 3,k])(Subscript[p, 1,k])(Subscript[p, 2,k])];
(Subscript[γ, 42])[1,k_]:=Evaluate[Plus[
Sum[(Subscript[g, ++κ])(Subscript[x, ν,k])(Subscript[p, ν,k]),{ν,3}],
Sum[(Subscript[g, ++κ])(Subscript[x, ν1,k])(Subscript[p, ν1,k])(Subscript[x, ν2,k])(Subscript[p, ν2,k]),{ν1,2},{ν2,ν1,3}]
]];
{(Subscript[γ, 0])[1,k],(Subscript[γ, 0])[1,k],(Subscript[γ, 42])[1,k]}

κ=0;
(Subscript[γ, 0])[-1,k_]:=Evaluate[(Subscript[h, ++κ])(Subscript[p, 3,k])(Subscript[x, 1,k])(Subscript[x, 2,k])];
(Subscript[γ, 1])[-1,k_]:=Evaluate[(Subscript[h, ++κ])(Subscript[x, 3,k])(Subscript[p, 1,k])(Subscript[p, 2,k])];
(Subscript[γ, 42])[-1,k_]:=Evaluate[Plus[
Sum[(Subscript[h, ++κ])(Subscript[x, ν,k])(Subscript[p, ν,k]),{ν,3}],
Sum[(Subscript[h, ++κ])(Subscript[x, ν1,k])(Subscript[p, ν1,k])(Subscript[x, ν2,k])(Subscript[p, ν2,k]),{ν1,2},{ν2,ν1,3}]
]];
{(Subscript[γ, 0])[-1,k],(Subscript[γ, 0])[-1,k],(Subscript[γ, 42])[-1,k]}

Reidemeister 3b

Timing[{LeftR3b}=Cases[∫ℱ[i,j,k]ℒ/@((Subscript[X, i,j])[1](Subscript[X, (SuperPlus[i]),k])[1](Subscript[X, (SuperPlus[j]),(SuperPlus[k])])[1])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, j]),(Subscript[vs, k]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, (SuperPlus[j])]),(Subscript[vs, (SuperPlus[k])])},𝔼[ℰ_]:>ℰ,∞]]

Timing[{RightR3b}=Cases[∫ℱ[i,j,k]ℒ/@((Subscript[X, j,k])[1](Subscript[X, i,(SuperPlus[k])])[1](Subscript[X, (SuperPlus[i]),(SuperPlus[j])])[1])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, j]),(Subscript[vs, k]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, (SuperPlus[j])]),(Subscript[vs, (SuperPlus[k])])},𝔼[ℰ_]:>ℰ,∞];]

Short[eqn=CF[LeftR3b[[1]]-RightR3b[[1]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[r, 0])[1,i,j],(Subscript[a, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
{sol}=Solve[eqns,vars]

sol/.(v_->val_):>(v=CF[val]);
(Subscript[r, 0])[1,i,j]

Short[eqn=CF[Coefficient[
LeftR3b[[2]]-RightR3b[[2]]/. v:(Subscript[(π|p), __]):>μ v,
(μ^3)
]],5]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[r, 1])[1,i,j],(Subscript[b, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
{sol}=Solve[eqns,vars]

sol/.(v_->val_):>(v=CF[val]);
(Subscript[r, 1])[1,i,j]

Short[eqn=CF[LeftR3b[[2]]-RightR3b[[2]]],5]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[r, 42])[1,i,j],(Subscript[c, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
Short[{sol}=Solve[eqns,vars]]

sol/.(v_->val_):>(v=CF[val]);

Short[CF[(Subscript[r, 42])[1,i,j]],20]

CF[LeftR3b-RightR3b]

Reidemeister 2b

Territory: (Subscript[(x|p), (SuperPlus[(i|j)])]), (Subscript[x, i|j]).

Timing[ Short[LeftR2b=(∫ℱ[i,j]ℒ/@((Subscript[X, i,j])[1](Subscript[X, (SuperPlus[i]),(SuperPlus[j])])[-1])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, j]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, (SuperPlus[j])])})[[1]]
]]

RightR2b=ϵSeries[(Subscript[p, 1,2+i]) (Subscript[π, 1,i])+(Subscript[p, 1,2+j]) (Subscript[π, 1,j])+(Subscript[p, 2,2+i]) (Subscript[π, 2,i])+(Subscript[p, 2,2+j]) (Subscript[π, 2,j])+(Subscript[p, 3,2+i]) (Subscript[π, 3,i])+(Subscript[p, 3,2+j]) (Subscript[π, 3,j]),0]

Short[eqn=CF[LeftR2b[[1]]-RightR2b[[1]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[r, 0])[-1,i,j],(Subscript[d, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
{sol}=Solve[eqns,vars]

sol/.(v_->val_):>(v=CF[val]);
(Subscript[r, 0])[-1,i,j]

Short[eqn=CF[LeftR2b[[2]]-RightR2b[[2]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[r, 1])[-1,i,j]+(Subscript[r, 42])[-1,i,j],(Subscript[e, _])|(Subscript[f, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
Short[{sol}=Solve[eqns,vars]]

sol/.(v_->val_):>(v=CF[val]);

(Subscript[r, 1])[-1,i,j]
Short[CF[(Subscript[r, 42])[-1,i,j]],5]

CF[LeftR2b-RightR2b]

Reidemeister 2c

Timing[ Short[{LeftR2c}=Cases[∫ℱ[i,j]ℒ/@((Subscript[X, i+1,j])[1](Subscript[X, i,j+2])[-1](Subscript[C, j+1])[1])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, j]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, (SuperPlus[j])]),(Subscript[vs, j+2])},𝔼[ℰ_]:>ℰ]
]]

Timing[ Short[{RightR2c}=Cases[∫ℱ[i,j]ℒ/@((Subscript[C, i])[0](Subscript[C, i+1])[0](Subscript[C, j])[0](Subscript[C, j+1])[1](Subscript[C, j+2])[0])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, j]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, (SuperPlus[j])]),(Subscript[vs, j+2])},𝔼[ℰ_]:>ℰ]
]]

Short[eqn=CF[LeftR2c[[1]]-RightR2c[[1]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[γ, 0])[1,k],(Subscript[g, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
{sol}=Solve[eqns,vars]

sol/.(v_->val_):>(v=CF[val]);
(Subscript[γ, 0])[1,k]

Short[eqn=CF[LeftR2c[[2]]-RightR2c[[2]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[γ, 1])[1,k]+(Subscript[γ, 42])[1,k],(Subscript[g, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
Short[{sol}=Solve[eqns,vars]]

sol/.(v_->val_):>(v=CF[val]);

(Subscript[γ, 1])[1,k]
Short[CF[(Subscript[γ, 42])[1,k]],5]

CF[LeftR2c-RightR2c]

(Subscript[C, k])[1] and (Subscript[C, k])[-1] are inverses

Timing[ Short[{LeftCC}=Cases[{∫ℱ[k]ℒ/@((Subscript[C, k])[1](Subscript[C, k+1])[-1])\[DifferentialD]{(Subscript[vs, k]),(Subscript[vs, (SuperPlus[k])])}},𝔼[ℰ_]:>ℰ]
]]

Timing[ Short[{RightCC}=Cases[{∫ℱ[k]ℒ/@((Subscript[C, k])[0](Subscript[C, k+1])[0])\[DifferentialD]{(Subscript[vs, k]),(Subscript[vs, (SuperPlus[k])])}},𝔼[ℰ_]:>ℰ]
]]

Short[eqn=CF[LeftCC[[1]]-RightCC[[1]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[γ, 0])[-1,k],(Subscript[h, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
{sol}=Solve[eqns,vars]

sol/.(v_->val_):>(v=CF[val]);
(Subscript[γ, 0])[-1,k]

Short[eqn=CF[LeftCC[[2]]-RightCC[[2]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[(Subscript[γ, 1])[-1,k]+(Subscript[γ, 42])[-1,k],(Subscript[h, _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
Short[{sol}=Solve[eqns,vars]]

sol/.(v_->val_):>(v=CF[val]);

(Subscript[γ, 1])[-1,k]
Short[CF[(Subscript[γ, 42])[-1,k]],5]

CF[LeftCC-RightCC]

Invariance Under R1l

{LeftR1l}=Cases[{∫ℱ[i]ℒ/@((Subscript[X, i+2,i])[1](Subscript[C, i+1])[1])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, i+2])}},𝔼[ℰ_]:>ℰ,∞]

{RightR1l}=Cases[{∫ℱ[i]ℒ/@((Subscript[C, i])[0](Subscript[C, i+1])[0](Subscript[C, i+2])[0])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, i+2])}},𝔼[ℰ_]:>ℰ,∞]

LeftR1l[[1]]==RightR1l[[1]]

Short[eqn=CF[LeftR1l[[2]]-RightR1l[[2]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[eqn,(Subscript[(c|d|e|f|g|h), _]),∞]
Short[eqns=If[cvs==={},
{eqn==0},
CoefficientRules[eqn,cvs]/.(_->c_):>(c==0)
],3]
{sol}=Solve[eqns,vars]

sol/.(v_->val_):>(v=CF[val]);

CF[LeftR1l-RightR1l]

Invariance Under R1r

{LeftR1r}=Cases[{∫ℱ[i]ℒ/@((Subscript[X, i,i+2])[1](Subscript[C, i+1])[-1])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, i+2])}},𝔼[ℰ_]:>ℰ,∞]

{RightR1r}=Cases[{∫ℱ[i]ℒ/@((Subscript[C, i])[0](Subscript[C, i+1])[0](Subscript[C, i+2])[0])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, i+2])}},𝔼[ℰ_]:>ℰ,∞]

LeftR1r[[1]]==RightR1r[[1]]

Short[eqn=CF[LeftR1r[[2]]-RightR1r[[2]]]]
cvs=Union@Cases[eqn,(Subscript[p, __])|(Subscript[π, __]),∞]
vars=Union@Cases[eqn,(Subscript[(c|d|e|f|g|h), _]),∞]
Short[eqns=CoefficientRules[eqn,cvs]/.(_->c_):>(c==0),3]
{sol}=Solve[eqns,vars]

sol/.(v_->val_):>(v=CF[val]);

CF[LeftR1r-RightR1r]

Invariance Under Sw

Timing[ Short[{LeftSw}=Cases[{∫ℱ[i,j]ℒ/@((Subscript[X, i+1,j+1])[1](Subscript[C, i])[-1](Subscript[C, j])[-1](Subscript[C, i+2])[1](Subscript[C, j+2])[1])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, j]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, (SuperPlus[j])]),(Subscript[vs, i+2]),(Subscript[vs, j+2])}},𝔼[ℰ_]:>ℰ,∞]
]]

Timing[ Short[{RightSw}=Cases[{∫ℱ[i,j]ℒ/@((Subscript[X, i+1,j+1])[1](Subscript[C, i])[0](Subscript[C, j])[0](Subscript[C, i+2])[0](Subscript[C, j+2])[0])\[DifferentialD]{(Subscript[vs, i]),(Subscript[vs, j]),(Subscript[vs, (SuperPlus[i])]),(Subscript[vs, (SuperPlus[j])]),(Subscript[vs, i+2]),(Subscript[vs, j+2])}},𝔼[ℰ_]:>ℰ,∞]
]]

LeftSw==RightSw

The Solution

Union@Cases[ℒ@(Subscript[X, i,j])[1],(Subscript[(a|b|c|d|e|f|g|h), _]),∞]

Some Knots

tab1=Last/@Table[K=Knot[n,1];
Echo@Timing[K->∫ℒ[K]\[DifferentialD] vs[K]],
{n,3,10}];

tab1[[1]]

K=Knot["K11n34"];Conway=∫ℒ[K]\[DifferentialD] vs[K]

K=Knot["K11n42"];KT=∫ℒ[K]\[DifferentialD] vs[K]

I Conway==I (Subscript[T, 1]^(-2)) (Subscript[T, 2]^(-2))KT