Pensieve header: Finding the MVA in β-calculus, with Oleg Chterental.

<< KnotTheory`

β=B[hs, ts, ω, Λ]

βSimplify[B[hs_, ts_, ω_, Λ_]] := B[hs, ts, Factor[ω],Sum[
Factor[Coefficient[Λ, t[u]h[x]]]*t[u]h[x],
{u,ts}, {x, hs}
]];
βForm[B[hs_, ts_, ω_, Λ_]] := Module[{mat},
mat = Table[
Coefficient[Λ, t[u]h[x]],
{u,ts}, {x, hs}
];
PrependTo[mat, hs];
mat = Transpose[Prepend[Transpose[mat], Prepend[ts, ω]]];
MatrixForm[mat]
];
Format[β_B, StandardForm] := βForm[β]

B /: B[hs1_, ts1_, ω1_, Λ1_]B[hs2_, ts2_, ω2_, Λ2_] := B[Union[hs1, hs2], Union[ts1, ts2], ω1*ω2, Λ1+Λ2] // βSimplify;
tm[u_,v_, w_][B[hs_, ts_, ω_, Λ_]] := B[
hs, Union[Complement[ts, {u,v}], {w}],
ω /. {t[u|v] -> t[w], T[u|v] -> T[w]},
Λ /. {t[u|v] -> t[w], T[u|v] -> T[w]}
] // βSimplify;
⟨μ_⟩ := μ /. t[u_] ->1;
hm[x_,y_, z_][B[hs_, ts_, ω_, Λ_]] := Module[{α, β, γ},
α = Coefficient[Λ, h[x]];
β = Coefficient[Λ, h[y]];
γ = Λ /. h[x|y] -> 0;
B[
Union[Complement[hs, {x,y}], {z}], ts,
ω, (α+β+⟨α⟩β)h[z]+γ
] // βSimplify
];
swap[u_,x_][B[hs_, ts_, ω_, Λ_]] := Module[{α, β, γ,δ,ϵ},
α = Coefficient[Λ, t[u]h[x]];
β = Coefficient[Λ /. h[x] -> 0, t[u]];
γ = Coefficient[Λ /. t[u] -> 0, h[x]];
δ = Λ /. {t[u]->0, h[x]->0};
ϵ = 1+α;
B[hs, ts, ω ϵ,
α(1+⟨γ⟩/ϵ)t[u]h[x]+β(1+⟨γ⟩/ϵ)t[u]
+ (γ/ϵ) h[x] + δ-γ β/ϵ
] // βSimplify
];
gm[a_,b_,c_][β_] := β // swap[a,b] // tm[a,b,a] // hm[a,b,a];
Rp[a_,b_] := B[{a,b}, {a,b}, 1, t[a]h[b](T[a]-1)];
Rm[a_,b_] := B[{a,b}, {a,b}, 1, t[a]h[b](1/T[a]-1)];

βZ[L_] := Module[{s,β},
s=Skeleton[L];
β=Times@@PD[L] /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]],
Rp[l,i], Rm[j,i]
];
Do[
β = β // gm[s[[c,1]], s[[c,k]], s[[c,1]]],
{c,1,Length[s]}, {k, 2, Length[s[[c]]]}
];
β
]

β=B[{1,2}, {1,2,3,4},ω, Sum[α[i,j]t[i]h[j], {i,1,4},{j,1,2}]]

β // tm[1,2,1]

β // tm[1,2,1] // tm[1,3,1]

β // tm[2,3,2] // tm[1,2,1]

β=B[{1,2,3,4}, {1,2}, ω, Sum[α[i,j]t[i]h[j], {i,1,2},{j,1,4}]]

β // hm[1,2,1]

β // hm[1,2,1] // hm[1,3,1]

β // hm[2,3,2] // hm[1,2,1]

(β // hm[1,2,1] // hm[1,3,1]) == (β // hm[2,3,2] // hm[1,2,1])

β=B[{1,2}, {1,2,3}, ω, Sum[α[i,j]t[i]h[j], {i,1,3},{j,1,2}]]

O1=β // tm[1,2,1] // swap[1,1]

O2=β // swap[2,1] // swap[1,1] // tm[1,2,1]

O1==O2

β=B[{1,2,3}, {1,2}, ω, Sum[(Subscript[α, i,j])t[i]h[j], {i,1,2},{j,1,3}]]

O1=β // hm[1,2,1] // swap[1,1]

O2=β // swap[1,1] // swap[1,2] // hm[1,2,1]

O1==O2

β=B[{1,2,3,4}, {1,2,3,4}, ω, Sum[(Subscript[α, i,j])t[i]h[j], {i,1,4},{j,1,4}]]

O1=β // gm[1,2,1] // gm[1,3,1]

O2=β // gm[2,3,2] // gm[1,2,1]

O1==O2

L=Knot["8_16"]

DrawMorseLink[L]

PD[L]

βZ[Knot[4,1]]

s=Skeleton[L]

β=Times@@PD[L] /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]],
Rp[l,i], Rm[j,i]
]

Do[
β = β // gm[s[[c,1]], s[[c,k]], s[[c,1]]],
{c,1,Length[s]}, {k, 2, Length[s[[c]]]}
]

β

Alexander[L][T[1]]

AllKnots[{3,7}]

Table[
Factor[βZ[L][[3]] / Alexander[L][T[1]]],
{L, AllKnots[{3,8}]}
]

βZ[Link["L6a4"]]

L=Link["L6a4"]

Skeleton[L]

βMVA0[L_] := Module[{hs, ts, ω,Λ,gs,mat,res},
{hs, ts, ω, Λ}=List@@βZ[L];
gs=First /@ Skeleton[L];
mat = Table[
Coefficient[Λ - (⟨Λ⟩ /. h[a_] :> t[a]h[a]), t[u]h[x]],
{u,gs//Rest}, {x,gs//Rest}
];
res=ω Det[mat]/(T[Skeleton[L][[1,1]]]-1) // Factor;
res /. T[k_] :> T[Position[gs, k][[1,1]]]
]

βtr[B[hs_, ts_, ω_, Λ_]] := Module[{mat,res},
mat = Table[
Coefficient[Λ - (⟨Λ⟩ /. h[a_] :> t[a]h[a]), t[u]h[x]],
{u,hs//Rest}, {x,hs//Rest}
];
res=ω Det[mat]/(T[ts[[1]]]-1) // Factor;
res /. T[k_] :> T[Position[hs, k][[1,1]]]
];
βMVA[L_] := βtr[βZ[L]]

βMVA[L]

MultivariableAlexander[L][T]

Table[
Factor[βMVA[L] / MultivariableAlexander[L][T]],
{L, AllLinks[{2,7}]}
]

β=B[{1,2,3}, {1,2,3}, ω, Sum[α[i,j]t[i]h[j], {i,1,3},{j,1,3}]]

β // gm[2,3,2]

β // gm[2,3,2] // βtr

β // gm[3,2,2]

β // gm[3,2,2] // βtr

(β // gm[2,3,2] // βtr) == (β // gm[3,2,2] // βtr)

n=5;
β=B[Range[n], Range[n], ω, Sum[α[i,j]t[i]h[j], {i,1,n},{j,1,n}]]

(β // gm[2,3,2] // βtr) == (β // gm[3,2,2] // βtr)

(β // gm[2,3,2]) == (β // gm[3,2,2])

n=2;
β=B[Range[n], Range[n], ω, Sum[α[i,j]t[i]h[j], {i,1,n},{j,1,n}]]

(β // gm[1,2,1] // βtr) == (β // gm[2,1,1] // βtr)

(β // gm[1,2,1]) == (β // gm[2,1,1])