Pensieve Header: β-Calculus rev. 2; rev. 3 in pensieve://2012-03/.

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[y]t[x]];
β = D[μ, t[x]] /. h[y] -> 0;
γ = D[μ, h[y]] /. t[x] -> 0;
δ = μ /. h[y]|t[x] -> 0;
ϵ = 1+(Subscript[c, x])α;
B[ω*ϵ, Plus[
α(1+(γ /. t[i_] :> (Subscript[c, i]))/ϵ)h[y]t[x],
β(1+(γ /. t[i_] :> (Subscript[c, i]))/ϵ)t[x],
γ/ϵ h[y],
δ-(Subscript[c, x])/ϵ γ*β
]] // βCollect
];

The “double” meta-group

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

The “external” product

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

“Braid-Like” operations

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 R-Matrix

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

Testing the meta-cross-product axioms

The “T” meta-group

{
β= B[ω[(Subscript[c, 1]),(Subscript[c, 2]),(Subscript[c, 3]),(Subscript[c, 4])],Sum[(Subscript[α, i])[(Subscript[c, 1]),(Subscript[c, 2]),(Subscript[c, 3]),(Subscript[c, 4])]t[i]h[1], {i,4}]],
β // tm[1,2,1],
t1=β // tm[1,2,1] // tm[1,3,1],
t2=β // tm[2,3,28] // tm[1,28,1],
t1==t2
} // βForm // ColumnForm

The “H” meta-group

{
β= B[ω,Sum[(Subscript[α, 10i+j])t[i]h[j], {i,2}, {j,4}]],
β // hm[1,2,1],
t1=β // hm[1,2,1] // hm[1,3,1],
t2=β // hm[2,3,28] // hm[1,28,1],
t1==t2
} // βForm // ColumnForm

{
β= B[ω,Sum[(Subscript[α, 10i+j])[(Subscript[c, 1]),(Subscript[c, 2])]*t[i]h[j], {i,2}, {j,2}]],
β // tΔ[2,2,3],
β // hΔ[2,2,3],
β // hΔ[2,2,3] // hS[3],
β // hΔ[2,2,3] // hS[3] // hm[2,3,2],
β // hΔ[2,2,3] // hS[3] // hm[3,2,2],
β  // hS[1],
β  // hS[1] // hS[1]
} // βForm // ColumnForm

{
β= B[ω,Sum[(Subscript[α, 10i+j])*t[i]h[j], {i,2}, {j,3}]],
t1=β // hm[1,2,1] // hS[1],
t2 = β // hS[1] // hS[2] // hm[2,1,1],
t1==t2 // Simplify
} // βForm // ColumnForm

Testing “thswap”

Clear[β];
{β1=B[ω, h[1]t[1]α+h[2]t[1]β+h[1]t[2]γ+h[2]t[2]δ],
β1 // thswap[1,1]
} // βForm

{
β= B[ω,Sum[(Subscript[α, 10i+j])t[i]h[j], {i,2}, {j,3}]],
β // hm[1,2,1],
t1 = β // hm[1,2,1] // thswap[1,1],
t2 = β // thswap[1,1] // thswap[1,2] //  hm[1,2,1],
t1 == t2 // Simplify
} // βForm // ColumnForm

{
β= B[ω,Sum[(Subscript[α, 10i+j])t[i]h[j], {i,3}, {j,2}]],
t1 = β // tm[1,2,1] // thswap[1,1],
t2 = β // thswap[2,1] // thswap[1,1] //  tm[1,2,1],
t1==t2 // Simplify
} // βForm // ColumnForm

The “double” meta-group

{β= B[ω,Sum[(Subscript[α, 10i+j])t[i]h[j], {i,4}, {j,4}]],
t1 = β // dm[1,2,1] // dm[1,3,1],
t2 = β // dm[2,3,2] // dm[1,2,1],
t1==t2 // Simplify
} // βForm // ColumnForm

The Knot-Theoretic Equations

R2, OC, R3 and easy R4

{R[1,2]Ri[3,4],
R[1,2]Ri[3,4] // dm[1,3,1] // dm[2,4,2],
R[1,2]Ri[3,4] // dm[1,3,1] // dm[4,2,2]
} // βForm

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

{
R[3,1]**R[3,2],
R[3,1],
R[3,1] // dΔ[1,1,2],
R[3,1]**R[3,2] == (R[3,1] // dΔ[1,1,2])
} // βForm

Hard R4

{
R[1,3]**R[2,3],
R[1,3] // dΔ[1,1,2],
R[1,3]**R[2,3] == (R[1,3] // dΔ[1,1,2])
} // βForm

{
V0=B[(Subscript[V, 0]),Sum[(Subscript[V, 10i+j])t[i]h[j], {i,2}, {j,2}]],
V0**R[1,3]**R[2,3],
(R[1,3] // dΔ[1,1,2])**V0,
V0**R[1,3]**R[2,3] == (R[1,3] // dΔ[1,1,2])**V0 // Simplify
} // βForm

((-1+(E^(Subscript[c, 1]))) (Subscript[c, 2])+(Subscript[c, 1]) (-(E^(Subscript[c, 1])) (-1+(E^(Subscript[c, 2])))+(-1+(E^((Subscript[c, 1])+(Subscript[c, 2])))) (Subscript[c, 2]) ((Subscript[V, 12])-(Subscript[V, 21]))))

Solve[(-1+(E^(Subscript[c, 1]))) (Subscript[c, 2])+(Subscript[c, 1]) (-(E^(Subscript[c, 1])) (-1+(E^(Subscript[c, 2])))+(-1+(E^((Subscript[c, 1])+(Subscript[c, 2])))) (Subscript[c, 2]) ((Subscript[V, 12])))==0, (Subscript[V, 12])]