Pensieve header: β-calculus revision 3.

Utilities

ℏ = 1;
βSimplify[expr_]:=expr // Together // ExpandDenominator // ExpandNumerator;
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[β];
Format[β_B, StandardForm] := βForm[β];
B /: B[ω1_, μ1_] == B[ω2_, μ2_] := Module[
{heads, tails},
tails = tL[{B[ω1, μ1], B[ω2, μ2]}];
heads = hL[{B[ω1, μ1], B[ω2, μ2]}];
(ω1 == ω2) && (
And @@ Flatten[Outer[
(Coefficient[μ1, t[#1]h[#2]] == Coefficient[μ2, t[#1]h[#2]])&,
tails, heads
]]
)
]

The Meta-Cross-Product

The “Tails” meta-group

tm[x_, y_, z_][β_] := βCollect[β /. {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  and HT -> TH Swaps

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
];
htswap[x_, y_][β_] := β // hS[x] // thswap[y,x] // hS[x];

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];
dS[s_][β_] := β // htswap[s,s] // hS[s] // tS[s];
dA[s_][β_] := β // htswap[s,s] // hA[s] // tA[s];
dη[s_][β_] := β // hη[s] // tη[s];
dcap[s_][β_] := β // htswap[s,s] // hη[s];
dP[rules___][β_] := β // hP[rules] // tP[rules];
dP[pl_List][β_] := Module[
{σ, len, β1, k},
len=Length[pl];
β1 = β // (dP @@ Table[i-> σ[i], {i, len}]);
Do[
k=pl[[i,1]];
β1=β1 // dP[σ[i] -> k];
Do[
β1 = β1 // dΔ[k, k, pl[[i,j]]],
{j,2, Length[pl[[i]]]}
],
{i, len}
];
β1
];
dP[pl___Integer] := dP[IntegerDigits /@ {pl}];

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, dL[ρ]}];
ReplacePart[ρ, 1 -> 1/ω] // βCollect
];

The R-Matrix

R[x_, y_, p_] := βCollect[B[1, (E^(p ℏ (Subscript[c, x]))-1)/(ℏ (Subscript[c, x]))*t[x]h[y]]];
R[x_, y_] := R[x,y,1];
Ri[x_, y_] := R[x,y,-1];
Θ[x_,y_,p_]:=(R[x,x,p/2] // dΔ[x,x,y])**R[x,x,-p/2]**R[y,y,-p/2];
Θ[x_,y_] := Θ[x,y,1];
Θi[x_,y_] := Θ[x,y,-1];

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

Testing “htswap”

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

{
β= B[ω,Sum[(Subscript[α, 10i+j])t[i]h[j], {i,2}, {j,3}]],
t1 = β // hm[1,2,1] // htswap[1,1],
t2 = β // htswap[2,1] // htswap[1,1] //  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] // htswap[1,1],
t2 = β // htswap[1,1] // htswap[1,2] //  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 “braid-like” operations

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

Some Knot-Theoretic Definitions

HardR4[V_] := (R[1,3]**R[2,3]**V)==(V**(R[1,3] // dΔ[1,1,2]));
TwistEq[V_] := (V // dP[2,1])**Θ[1,2]==R[1,2]**V;
CapEquation[V_, Cap_] := (V**(Cap // dP[12])  // dcap[1] // dcap[2]) == (Cap(Cap // dP[2]) // dcap[1] // dcap[2]);
Φ[V_] := (Inverse[V] // dP[12,3])**Inverse[V]**(V // dP[2,3])**(V // dP[1,23]);
Pentagon[Φ_] := Φ ** (Φ // dP[1,23,4]) ** (Φ // dP[2,3,4]) == (Φ // dP[12,3,4])**(Φ // dP[1,2,34]);
Hexagon[s_, Φ_] := Equal[
Θ[1,2,s]//dP[12,3],
Φ**Θ[2,3,s]**Inverse[Φ//dP[1,3,2]]**Θ[1,3,s]**(Φ//dP[3,1,2])
];
Rot120[β_] := β // dS[2] // dΔ[2,2,3] // dm[1,3,1] // dP[2,1];

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