Pensieve Header: The β invariants of braids.

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
];

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

((-1+(E^(Subscript[c, 2])))/(Subscript[c, 2]))+-(((-1+(E^(Subscript[c, 1]))) (-1+(E^(Subscript[c, 2]))))/(Subscript[c, 2])) // Simplify

(E^(Subscript[c, 2])) (-1+(E^(Subscript[c, 1]))) (1+(E^(Subscript[c, 1])))-(-1+(E^(Subscript[c, 1]))) (1+(E^(Subscript[c, 1]))) (-1+(E^(Subscript[c, 2]))) // Simplify