Pensieve Header: The Burau representation in β-calculus.

The first two sections are borrowed from betaCalculus.nb; the third largely from 2012-01/betaCalculus.nb.

<< KnotTheory`
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]
]
)

Utilities

βSimplify=Factor;
SetAttributes[βCollect, Listable];
βCollect[B[ω_, μ_]] := B[
βSimplify[ω],
Collect[μ, _h, Collect[#, _t, βSimplify]&]
];
(* "L" for "Labels" *)
hL[β_] := Union[Cases[β, h[s_] :> s, Infinity]];
tL[β_] := Union[Cases[β, t[s_]|(Subscript[c, s_]) :> s, Infinity]];
dL[β_] := Union[hL[β], tL[β]];
βForm[B[ω_, μ_]] := Module[
{tails, heads, mat},
tails = tL[B[ω, μ]]; heads = hL[B[ω, μ]];
mat = Outer[βSimplify[Coefficient[μ, h[#1] t[#2]]]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Prepend[Transpose[mat], Prepend[h /@ heads, ω]];
MatrixForm[mat]
];
βForm[else_] := else /. β_B :> βForm[β];
B /: B[ω1_, β1_] == B[ω2_, β2_] := (ω1 == ω2) && (β1 == β2);

The Meta-Cross-Product

The “Tails” meta-group

tm[x_, y_, z_][β_] := β /. {t[x]->t[z], t[y]->t[z], (Subscript[c, x])->(Subscript[c, z]), (Subscript[c, y])->(Subscript[c, z])};
tΔ[z_, x_, y_][β_] := βCollect[β /. {t[z] -> t[x]+t[y], (Subscript[c, z]) -> (Subscript[c, x])+(Subscript[c, y])}];
tη[x_][β_] := βCollect[(β /. t[x] -> 0) /. (Subscript[c, x])->0];
tS[x_][β_] := βCollect[β /. {t[x] -> -t[x], (Subscript[c, x]) -> -(Subscript[c, x])}];
tA[_][β_] := βCollect[β];
tP[rules___Rule][β_] := βCollect[
β /. {t[x_] :> t[x /. {rules}], (Subscript[c, x_]) :> (Subscript[c, x /. {rules}])}
];

The “Heads” meta-group

hm[x_, y_, z_][B[ω_, μ_]] := Module[
{γx= D[μ, h[x]], γy=D[μ, h[y]], M=μ /. h[x]|h[y] -> 0},
B[ω, M+h[z](γx+γy+(γx /. t[i_] :> (Subscript[c, i]))γy)] // βCollect
];
hΔ[z_, x_, y_][β_] := βCollect[β /. h[z] -> h[x]+h[y]];
hη[x_][β_] := βCollect[β /. h[x] -> 0];
hS[x_][B[ω_, μ_]] := Module[{γ},
γ = 1 + D[μ, h[x]] /. t[s_]:>(Subscript[c, s]);
βCollect[B[ω, μ /. h[x] -> -h[x]/γ]]
];
hA[x_][β_] := hS[x][β];
hP[rules___Rule][β_] := βCollect[β /. h[x_] :> h[x /. {rules}]];

The TH -> HT Swap

thswap[x_,y_][B[ω_, μ_]] := Module[
{α, β, γ, δ, ϵ},
α = Coefficient[μ, h[x]t[y]];
β = D[μ, t[y]] /. h[x] -> 0;
γ = D[μ, h[x]] /. t[y] -> 0;
δ = μ /. h[x]|t[y] -> 0;
ϵ = 1+(Subscript[c, y])α;
B[ω*ϵ, Plus[
α(1+(γ /. t[i_] :> (Subscript[c, i]))/ϵ)h[x]t[y],
β(1+(γ /. t[i_] :> (Subscript[c, i]))/ϵ)t[y],
γ/ϵ h[x],
δ-(Subscript[c, y])/ϵ γ*β
]] // βCollect
];

The “double” meta-group

dm[x_,y_,z_][β_] := β // thswap[y,x] // hm[x,y,z] // tm[x,y,z];

The “external” product

B /: B[ω1_, μ1_]B[ω2_, μ2_] := B[ω1*ω2, μ1+μ2];

The R-Matrix

R[x_, y_] := B[1, (E^(Subscript[c, x])-1)/(Subscript[c, x])*t[x]h[y]];
Rinv[x_, y_] := B[1, (E^(-(Subscript[c, x]))-1)/(Subscript[c, x])*t[x]h[y]];

The Group (Subscript[A, n])

ar[i_,j_] := t[i]h[j];
htswap[y_,x_][β_] := β // hS[x] // thswap[y,x] // hS[x];
dA[x_][β_] := β // tA[x] // htswap[x,x] // hA[x];
dS[x_][β_] := β // tS[x] // htswap[x,x] // hS[x];

Unprotect[NonCommutativeMultiply];
β_ ** ν_ := Module[
{ρ, σ, labels},
ρ = β*(ν /. {h[s_] :> h[σ[s]], t[s_] :> t[σ[s]], (Subscript[c, s_]) :> (Subscript[c, σ[s]])});
labels = Union[Cases[{β,ν}, h[s_]|t[s_]|(Subscript[c, s_]) :> s, Infinity]];
Do[
ρ = ρ // dm[s, σ[s], s],
{s, labels}
];
ρ
];
B /: Inverse[B[ω_, μ_]] := Module[
{ρ = B[1, μ]},
Do[ρ = ρ // dA[s], {s, Union[hL[ρ], tL[ρ]]}];
ReplacePart[ρ, 1 -> 1/ω] // βCollect
];

The Burau Representation

Burau[B[_, μ_]] := Module[
{labels, ν},
labels = Union[hL[μ], tL[μ]];
ν = (μ /. h[j_] :> -(Subscript[c, j])h[j]) + (μ /. t[i_] :> (Subscript[c, i]) /. h[j_] :> t[j]h[j]);
Outer[Coefficient[ν, t[#2]h[#1]]&, labels, labels] + IdentityMatrix[Length[labels]]
];
Burau[n_, B[_, μ_]] := Module[
{labels, ν},
labels = Range[n];
ν = (μ /. h[j_] :> -(Subscript[c, j])h[j]) + (μ /. t[i_] :> (Subscript[c, i]) /. h[j_] :> t[j]h[j]);
Outer[Coefficient[ν, t[#2]h[#1]]&, labels, labels] + IdentityMatrix[n]
];

Testing

{
R[1,2]**R[1,3]**R[2,3],
R[2,3]**R[1,3]**R[1,2]
} // βForm

n=3;
{
α1=B[1,Sum[(Subscript[α, 10i+j]) ar[i,j], {i,n}, {j,n}]],
β1=B[1, Sum[(Subscript[β, 10i+j]) ar[i,j], {i,n}, {j,n}]],
α1**β1
} // βForm // ColumnForm

n=2;
{
α1=B[1,Sum[(Subscript[α, 10i+j]) ar[i,j], {i,n}, {j,n}]],
β1=α1 // dS[1] // dS[2],
α1**β1
} // βForm // ColumnForm

n=3;
{
α1=B[ω,Sum[(Subscript[α, 10i+j]) ar[i,j], {i,n}, {j,n}]],
β1=α1 // dA[1] // dA[2] // dA[3],
α1**β1,
α1**Inverse[α1]
} // βForm // ColumnForm

{
α1=R[1,2]**R[2,3],
β1=α1 // dA[1] // dA[2] // dA[3],
Inverse[α1],
α1**β1
} // βForm // ColumnForm

n=3;
{
α1=B[ω,Sum[(Subscript[α, 10i+j]) ar[i,j], {i,n}, {j,n}]],
Inverse[α1]**α1,
(α1**B[1,ϵ*ar[1,0]]**Inverse[α1]) // βCollect,
Inverse[α1]**B[1,ϵ*ar[1,0]]**α1,
Inverse[α1]**B[1,ϵ*ar[2,0]]**α1,
Burau[α1] // MatrixForm
} // βForm // ColumnForm

n=3;
{
α1=B[ω,Sum[(Subscript[α, 10i+j]) ar[i,j], {i,n}, {j,n}]],
β1=B[ω,Sum[(Subscript[β, 10i+j]) ar[i,j], {i,n}, {j,n}]],
(t1 = Burau[α1]) // MatrixForm,
(t2 = Burau[β1]) // MatrixForm,
(t3=Burau[α1**β1]) // Expand// MatrixForm,
t1.t2 // Expand // MatrixForm,
Expand[t1.t2==t3]
} // βForm // ColumnForm

Burau[5, R[1,2]] // MatrixForm

Burau[5, R[1,2]**R[2,3]**Rinv[1,2]**Rinv[2,3]] // MatrixForm

R[1,2]**R[2,3]**Rinv[1,2]**Rinv[2,3] // βForm

βMVA[L_Link] := Module[
{skel, β, s, k},
skel=Skeleton[L];
β=Times @@ GD[L] /. {Ar[x_,y_,+1] :> R[x,y],  Ar[x_,y_, -1] :> Rinv[x,y]};
Do[
Do[
β = β // dm[skel[[s,1]], skel[[s,k]], skel[[s,1]]],
{k, 2, Length[skel[[s]]]}
],
{s, Length[skel]}
];
β
]

MultivariableAlexander[L=Link["L6a5"]][T] /. T[i_] :> (Subscript[T, i])

(β0 = βMVA[L]) // βForm

(β1= βCollect[β0 /. B[ω_, μ_] :> B[ω, ω*μ]]) // βForm

Collect[β0[[2]] /. t[i_] :> (Subscript[c, i]), _h, Simplify]

Simplify[Burau[β0]] // MatrixForm

Simplify[Burau[β0].{(Subscript[c, 1]), (Subscript[c, 5]), (Subscript[c, 9])}]

((E^(-2 (Subscript[c, 1])-2 (Subscript[c, 5])-2 (Subscript[c, 9]))) (-1+(E^(Subscript[c, 1]))+(E^(Subscript[c, 5]))) (-1+(E^(Subscript[c, 1]))+(E^(Subscript[c, 9]))) (-1+(E^(Subscript[c, 5]))+(E^(Subscript[c, 9]))))*Det[Simplify[Burau[β0]]] // Simplify