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

Work in Progress

GD[K_] := GD @@ (
PD[K] /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]],
Ar[l,i,+1], Ar[j,i,-1]
]
)

βZ[L_] := Module[
{skel, β, s, k},
skel=Skeleton[L];
β=Times @@ GD[L] /. {Ar[x_,y_,+1] :> (Subscript[((SuperPlus[R])), x,y]),  Ar[x_,y_, -1] :> (Subscript[((SuperMinus[R])), x,y])};
Do[
Do[
β = β // (Subscript[gm, skel[[s,1]], skel[[s,k]]->skel[[s,1]]]),
{k, 2, Length[skel[[s]]]}
],
{s, Length[skel]}
];
β
]

βZ[Knot[8,17]][[1]]

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

βCollect[Bu[ω_, λ_, μ_]] := Bu[
βSimp[ω],
Collect[λ, (Subscript[h, _]), βSimp],
Collect[μ, (Subscript[h, _]), Collect[#, (Subscript[t, _]), βSimp]&]
];
Bu[ηs_List, B[ω_, μ_]] :=  Module[{λ},
λ = (1+Coefficient[μ, #] /. (Subscript[t, _]) -> 1)& /@ ηs;
Bu[ω,
Thread[ηs -> λ],
-μ +(ηs /. (Subscript[h, a_]) :> (Subscript[t, a])(Subscript[h, a])).λ
]// βCollect
];
B[Bu[ω_, λ_, μ_]] := 0;

β0 = βZ[L=Link["L6a5"]]

Bu[{(Subscript[h, 1]), (Subscript[h, 5]), (Subscript[h, 9])},β0]

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

βMVA[L]

βMVA[L=Link["L8a16"]]

βZ[L]

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