Pensieve header: Programs for β-calculus, development notebook.

<< KnotTheory`

βSimp=Factor; SetAttributes[βCollect, Listable];
βCollect[B[ω_, Λ_]] := B[βSimp[ω],
Collect[Λ, (Subscript[h, _]), Collect[#,(Subscript[t, _]), βSimp]&]];
βForm[B[ω_, Λ_]] := Module[{ts, hs, M},
ts = Union[Cases[B[ω, Λ], (Subscript[(t|T), s_]) :> s, Infinity]];
hs = Union[Cases[B[ω, Λ], (Subscript[h, s_]) :> s, Infinity]];
M = Outer[βSimp[Coefficient[Λ, (Subscript[h, #1]) (Subscript[t, #2])]]&, hs, ts];
PrependTo[M, (Subscript[t, #])& /@ ts];
M = Prepend[Transpose[M], Prepend[(Subscript[h, #])& /@ hs, ω]];
MatrixForm[M]];
βForm[else_] := else /. β_B :> βForm[β];
Format[β_B, StandardForm] := βForm[β];

⟨μ_⟩ := μ /. (Subscript[t, _])->1;
(Subscript[tm, x_,y_->z_])[β_] := βCollect[β /. {(Subscript[t, x|y])->(Subscript[t, z]), (Subscript[T, x|y])->(Subscript[T, z])}];
(Subscript[hm, x_,y_->z_])[B[ω_, Λ_]] := Module[
{α= D[Λ, (Subscript[h, x])], β=D[Λ, (Subscript[h, y])], γ=Λ /. (Subscript[h, x|y]) -> 0},
B[ω, (α+(1+⟨α⟩)β)(Subscript[h, z])+γ] // βCollect];
(Subscript[sw, x_,y_])[B[ω_, Λ_]] := Module[{α,β,γ,δ,ϵ},
α = Coefficient[Λ, (Subscript[h, y])(Subscript[t, x])]; β = D[Λ, (Subscript[t, x])] /. (Subscript[h, y]) -> 0;
γ = D[Λ, (Subscript[h, y])] /. (Subscript[t, x]) -> 0;      δ = Λ /. (Subscript[h, y])|(Subscript[t, x]) -> 0;
ϵ = 1+α;
B[ω*ϵ, α(1+⟨γ⟩/ϵ)(Subscript[h, y])(Subscript[t, x]) + β(1+⟨γ⟩/ϵ)(Subscript[t, x])
      +γ/ϵ (Subscript[h, y])                          + δ-γ*β/ϵ
] // βCollect];
(Subscript[gm, x_,y_->z_])[β_] := β // (Subscript[sw, x,y]) // (Subscript[hm, x,y->z]) // (Subscript[tm, x,y->z]);
B /: B[ω1_, Λ1_]B[ω2_, Λ2_] := B[ω1*ω2, Λ1+Λ2];
(Subscript[((SuperPlus[R])), x_,y_]) := B[1, ((Subscript[T, x])-1)(Subscript[t, x])(Subscript[h, y])];
(Subscript[((SuperMinus[R])), x_,y_]) := B[1, (((((Subscript[T, x])))^(-1))-1)(Subscript[t, x])(Subscript[h, y])];

{β= B[ω,Sum[(Subscript[α, 2i+j-6])(Subscript[t, i])(Subscript[h, j]), {i,1,4}, {j,5,6}]],
(Subscript[O, 1])=β//(Subscript[tm, 1,2->1])//(Subscript[tm, 1,3->1]),
(Subscript[O, 2])=β//(Subscript[tm, 2,3->2])// (Subscript[tm, 1,2->1]),
(Subscript[O, 1])==(Subscript[O, 2])
} // ColumnForm

{β= B[ω,Sum[(Subscript[α, 4i+j-6])(Subscript[t, i])(Subscript[h, j]), {i,1,2}, {j,3,6}]],
(Subscript[O, 1])=β//(Subscript[hm, 3,4->3])//(Subscript[hm, 3,5->3]),
(Subscript[O, 2])=β//(Subscript[hm, 4,5->4])// (Subscript[hm, 3,4->3]);
(Subscript[O, 1])==(Subscript[O, 2])
} /. (Subscript[α, i_]):> (OverHat[i]) // ColumnForm

{β= B[ω,Sum[(Subscript[α, 2i+j-5])(Subscript[t, i])(Subscript[h, j]), {i,1,3}, {j,4,5}]],
(Subscript[O, 1])=β//(Subscript[tm, 1,2->1])//(Subscript[sw, 1,4]),
(Subscript[O, 2])=β//(Subscript[sw, 2,4])// (Subscript[sw, 1,4])// (Subscript[tm, 1,2->1]);
(Subscript[O, 1])==(Subscript[O, 2])}

{β= B[ω,Sum[(Subscript[α, 3i+j-5])(Subscript[t, i])(Subscript[h, j]), {i,1,2}, {j,3,5}]],
(Subscript[O, 1])=β//(Subscript[hm, 3,4->3])//(Subscript[sw, 1,3]) // βCollect,
(Subscript[O, 2])=β//(Subscript[sw, 1,3])// (Subscript[sw, 1,4])// (Subscript[hm, 3,4->3]) // βCollect;
(Subscript[O, 1])==(Subscript[O, 2])
} /. (Subscript[α, i_]):> (OverHat[i]) // ColumnForm

{(Subscript[((SuperMinus[R])), 5,1])(Subscript[((SuperMinus[R])), 6,2])(Subscript[((SuperPlus[R])), 3,4])//(Subscript[gm, 1,4->1])//(Subscript[gm, 2,5->2])//(Subscript[gm, 3,6->3]),
 (Subscript[((SuperPlus[R])), 6,1])(Subscript[((SuperMinus[R])), 2,4])(Subscript[((SuperMinus[R])), 3,5])//(Subscript[gm, 1,4->1])//(Subscript[gm, 2,5->2])//(Subscript[gm, 3,6->3])}

β=(Subscript[((SuperMinus[R])), 12,1])(Subscript[((SuperMinus[R])), 2,7])(Subscript[((SuperMinus[R])), 8,3])(Subscript[((SuperMinus[R])), 4,11])(Subscript[((SuperPlus[R])), 16,5])(Subscript[((SuperPlus[R])), 6,13])(Subscript[((SuperPlus[R])), 14,9])(Subscript[((SuperPlus[R])), 10,15])

Do[β = β // (Subscript[gm, 1,k->1]), {k,2,10}]; β

Do[β = β // (Subscript[gm, 1,k->1]), {k,11,16}]; β

Alexander[Knot[8,17]][X]

Recycling

(({{1, 0, 0, 0, 0, T-1, 0, -T}, {-1, T, 0, 0, 0, 0, 1-T, 0}, {0, -1, T, 0, 1-T, 0, 0, 0}, {T-1, 0, -T, 1, 0, 0, 0, 0}, {0, 1-T, 0, -1, T, 0, 0, 0}, {0, 0, 0, 0, -T, 1, 0, T-1}, {0, 0, 1-T, 0, 0, -1, T, 0}, {0, 0, 0, T-1, 0, 0, -T, 1}}))[[1;;7,1;;7]] // Det

The Borromean Link

β= (Subscript[((SuperMinus[R])), r,6])(Subscript[((SuperPlus[R])), 2,4])(Subscript[((SuperMinus[R])), g,9])(Subscript[((SuperPlus[R])), 5,7])(Subscript[((SuperMinus[R])), b,3])(Subscript[((SuperPlus[R])), 8,1])

Do[β = β // (Subscript[gm, r,k->r]), {k,1,3}];
Do[β = β // (Subscript[gm, g,k->g]), {k,4,6}];
Do[β = β // (Subscript[gm, b,k->b]), {k,7,9}];
β /. {(Subscript[T, c_]):>c}

Work in Progress

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

βZ[Knot[8,17]]//First

Factor[((βZ[#][[1]])/(Alexander[#][(Subscript[T, 1])]))]& /@ AllKnots[{3,8}]

βMVA[L_Link] := Module[{ηs, ω, μ, M},
{ω, μ} = List @@ βZ[L];
ηs = Rest[(Subscript[h, #])& /@ (First /@ Skeleton[L])];
M=Outer[
Coefficient[μ - (μ /. (Subscript[t, _])->1 /. (Subscript[h, a_]) :> (Subscript[t, a])(Subscript[h, a])), #1*#2]&,
ηs, ηs /. (Subscript[h, a_]) :> (Subscript[t, a])];
Factor[((ω Det[M])/(1-(Subscript[T, Skeleton[L][[1,1]]])))]]

βMVA[Link["L8a16"]]

Simplify[(((MultivariableAlexander[#][T] /. T[i_] :> (Subscript[T, Skeleton[#][[i,1]]])))/(βMVA[#]))]&  /@ AllLinks[8]