Pensieve Header: The β-calculus, continuing pensieve://Projects/w-Computations/, continued in pensieve://2012-02/ and pensieve://2012-03/.

β is to remind of “B picture”, though it is “wheeled”. Also, in faux German, β is ß is SS, for “semi-symmetrized”.

Continues “Projects/w-Computations/Wheeled Semi-Symmetrized 2D Calculus.nb” and other notebooks referenced there.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2012-01"];

Generalities

βSimplify=Factor;

ar[i_,j_] := t[i]h[j];

W /: W[a_] + W[b_] := W[βSimplify[a*b]];
W /: n_*W[a_] := W[βSimplify[a^n]];

SetAttributes[βCollect, Listable];
βCollect[β_] := Collect[β, _h, Collect[#, _t, βSimplify]&] /. W[ws_] :> W[βSimplify[ws]];
(* "L" for "Labels" *)
hL[β_] := Union[Cases[β, h[s_] :> s, Infinity]];
tL[β_] := Union[Cases[β, (t|c)[s_] :> s, Infinity]];
dL[β_] := Union[hL[β], tL[β]];
SetAttributes[βForm, Listable];
βForm[β_] := Module[
{tails, heads, mat},
tails = tL[β]; heads = hL[β];
mat = Outer[βSimplify[Coefficient[β, h[#1] t[#2]]]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Prepend[Transpose[mat], Prepend[h /@ heads, β /. (h[_]|t[_]) -> 0]];
MatrixForm[mat]
];
βEquations[β1_ == β2_] := Module[
{tails, heads, l1,l2},
tails = tL[{β1, β2}]; heads = hL[{β1, β2}];
l1 = Flatten[Outer[βSimplify[Coefficient[β1, h[#1] t[#2]]]&, heads, tails]];
l2 = Flatten[Outer[βSimplify[Coefficient[β2, h[#1] t[#2]]]&, heads, tails]];
Append[
MapThread[Equal, {l1, l2}],
(β1==β2) /. (h[_]|t[_]) -> 0 /. W[ω_] :> ω
]
];

Wheel / DeWheel

DeWheel[β_] := Module[
{heads, ξs, nheads},
heads = Union[Cases[β, h[s_] :> s, Infinity]];
ξs = (D[β, h[#]] /. t[s_] :>c[s])& /@ heads;
nheads = MapThread[(h[#1]*Log[1+#2]/#2)&, {heads, ξs}];
βCollect[β /. Thread[(h/@heads) -> nheads]]
];
Wheel[α_] := Module[
{heads, ηs, nheads},
heads = Union[Cases[α, h[s_] :> s, Infinity]];
ηs = (D[α, h[#]] /. t[s_] :>c[s])& /@ heads;
nheads = MapThread[(h[#1]*(Exp[#2]-1)/#2)&, {heads, ηs}];
βCollect[α /. Thread[(h/@heads) -> nheads]]
];

ar[1,2] // Wheel

(((-1+(E^(c[1]))) h[2] t[1])/(c[1])) // DeWheel

(Sum[(Subscript[α, 10i+j]) ar[i,j], {i,2}, {j,3}] // Wheel // DeWheel // FullSimplify) /. Log[Exp[x_]] :> x// βForm

Sum[(Subscript[α, 10i+j]) ar[i,j], {i,2}, {j,3}] // DeWheel // Wheel // FullSimplify // βForm

Tails Works

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

Heads Works

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

hm[3,4,5][ar[1,3]+ar[2,4]]

hm[3,4,5][ar[1,3]+ar[2,4]] // βForm

{β=ar[1,3]+ar[2,4],
β // hP[3->7, 4->2]
} // βForm

Associativity of Heads Multiplication

β1=α1 ar[1,1]+α2 ar[2,2]+α3 ar[3,3]

{β1, β1 // hm[1,2,1]} // βForm

{t1=β1 // hm[1,2,1] // hm[1,3,1], t2 = β1 // hm[2,3,2] // hm[1,2,1]} // βForm

t1==t2 // βSimplify

Compatibility of m and Δ

{
β1=α1 ar[1,1]+ α2 ar[2,2],
t1 = β1 // hΔ[1,1,3] // hΔ[2,2,4] // hm[1,2,1] // hm[3,4,2],
t2 = β1 // hm[1,2,1] // hΔ[1,1,2]
} // βForm

t1 == t2

The Square of the Antipode

{β1 = α ar[1,1],
β1 // hS[1],
β1 // hS[1] // hS[1]
} // βForm

The Antipode is an Anti-Homomorphism

{β1=α1 ar[1,1]+ α2 ar[2,2],
β1 // hm[1,2,3],
β1 // hm[2,1,3],
t1 = β1 // hm[1,2,3] // hS[3],
t2 = β1 // hS[1] // hS[2] // hm[2,1,3]
} // βForm

t1==t2 // βSimplify

The Antipode “Inverse” Property

{
α ar[1,1] // hΔ[1,1,2] // hS[2] // hm[1,2,1],
α ar[1,1] // hΔ[1,1,2] // hS[2] // hm[2,1,1]
}

The Antipode and de-wheeling

{
β1 = W[1]+ a ar[1,1] + b ar[1,2] + c ar[2,1] +d ar[2,2],
β1 // hS[1] // DeWheel,
β1 // DeWheel
} // βForm

(1-((a c[1])/(1+a c[1]+c c[2]))-((c c[2])/(1+a c[1]+c c[2])))(1+a c[1]+c c[2]) // Simplify

{
β1 = W[1]+ a ar[1,1] + b ar[1,2] + c ar[2,1] +d ar[2,2],
β1 // hS[1],
((β1 // DeWheel) /. h[1] -> -h[1]) // Wheel // FullSimplify
} // βForm

Factorization

hfac[z_, xtails_List -> x_, y_][β_] := Module[
{ytails},
ytails = Complement[
Union[Cases[β, t[s_] :> s, Infinity]],
xtails
];
hfac[z,xtails -> x, ytails -> y][β]
];
hfac[z_, x_,  ytails_List -> y_][β_] := Module[
{xtails},
xtails = Complement[
Union[Cases[β, t[s_] :> s, Infinity]],
ytails
];
hfac[z,xtails -> x, ytails -> y][β]
];
hfac[z_, xtails_List -> x_, ytails_List -> y_][β_] := Module[
{ζ, ξ, η},
ζ = D[β, h[z]];
ξ = ζ /. ((t[#]->0)& /@ ytails);
η = ζ /. ((t[#]->0)& /@ xtails);
βCollect[β-h[z]ζ + h[x]ξ + h[y]η/(1+ξ /. t[s_]->c[s])]
]

hm[3,4,5][ar[1,3]+ar[2,4]] // βForm

hm[3,4,5][ar[1,3]+ar[2,4]] // hfac[5,{1}->3, 4] // βForm

Conjugation

conj[y_,x_][β_] := Module[
{ν, x0, x1, γ, ξ, η, a},
ν = β // hfac[x, {y} -> x0, x1];
γ = Coefficient[ν, ar[y,x0]];
ν = βCollect[ν /. W[ws_] :> W[ws*(c[y]γ+1)]];
ξ = D[ν, h[x1]];
η = D[ν, t[y]];
a = 1 + ξ /. t[s_] :> c[s];
ν = βCollect[(ν /. t[y] -> a t[y]) -c[y] ξ η];
ν // hm[x0,x1,x]
];
conji[y_,x_][β_] := β // hS[x] // conj[y,x] // hS[x];

{
β1 = W[1]+ a[c[1],c[2]] ar[1,1] + b[c[1],c[2]] ar[1,2] + c[c[1],c[2]] ar[2,1] +d[c[1],c[2]] ar[2,2],
β1 // conj[1,1],
β1 // conji[1,1],
β1 // conj[1,1] // conji[1,1]
} /. e_[c[1],c[2]] :> e // βForm

(β2 = W[1]+(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[2,1] + (Subscript[α, 3]) ar[2,2] + (Subscript[α, 4]) ar[2,3]) // βForm;
(β2 = W[1]+Sum[(Subscript[α, 10i+j]) ar[i,j], {i,2}, {j,3}]) // βForm

β2 // conj[1,2] // βForm

(t1 = β2 // conj[1,2] // conj[1,3] // hm[2,3,2]) // βForm

(t2 = β2 //  hm[2,3,2] // conj[1,2]) // βForm

βSimplify[t1==t2]

βSimplify[(β2 // conji[1,2] // conji[1,3] // hm[3,2,2])== (β2 //  hm[3,2,2] // conji[1,2])]

{β3 = W[1]+Sum[(Subscript[α, 10i+j]) ar[i,j], {i,3}, {j,2}],
t1 = β3 // tm[1,2,1] // conj[1,1],
t2 = β3 // conj[1,1] // conj[2,1] // tm[1,2,1],
t1==t2
} // βForm // MatrixForm

“4T”

Riffle[
ComposeList[
ops={conj[2,1], hΔ[1,1,3], hm[2,3,2], hΔ[1,1,3], hS[3], hm[3,2,2]},
(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[2,2]
]// βForm,
ops
]

{
β1 = R[1,1] + R[2,2],
β1 // conj[2,1] // hΔ[1,1,3] // hm[2,3,2]//hΔ[1,1,3] // hS[3] // hm[3,2,2]
} // βForm

Riffle[
ComposeList[
ops={hΔ[1,1,3], hm[2,3,2], hΔ[1,1,3], hS[3], hm[3,2,2]},
(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[1,2]
]// βForm,
ops
]

The Double

dm[x_,y_,z_][β_] := β // conji[y,x] // hm[x,y,z] // tm[x,y,z];
dΔ[z_, x_, y_][β_] := β // hΔ[z,x,y] // tΔ[z,x,y];
dη[x_][β_] := β // hη[x] // tη[x];
dS[x_][β_] := β // tS[x] // conj[x,x] // hS[x];
dA[x_][β_] := β // tA[x] // conj[x,x] // hA[x];
dP[rules___Rule][β_] := β // hP[rules] // tP[rules];
dP[ks__Integer][β_] := β // (dP @@ Thread[Range[Length[{ks}]] -> {ks}]);
dd[k_][β_] := Module[
{shifts},
shifts = Select[dL[β], (#>k)&];
β // (dP @@ Thread[shifts -> (1+shifts)]) // dΔ[k, k, k+1]
];

Unprotect[NonCommutativeMultiply];
β_ ** ν_ := Module[
{ρ, σ, labels},
ρ = β + (ν /. {h[s_] :> h[σ[s]], t[s_] :> t[σ[s]], c[s_] :> c[σ[s]]});
labels = Union[Cases[{β,ν}, h[s_]|t[s_]|c[s_] :> s, Infinity]];
Do[
ρ = ρ // dm[s, σ[s], s],
{s, labels}
];
ρ
]

ar[1,2]**ar[1,3]// βForm

ar[1,3]**ar[2,3] // βForm

ar[1,2]**ar[2,3] // βForm

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

ar[1,3]**ar[1,2] // βForm

ar[2,3]**ar[1,3] // βForm

ar[2,3]**ar[1,2] // βForm

{ar[1,2] // dS[1] , ar[1,2] // dS[2]}

{β3 = W[1]+Sum[(Subscript[α, 10i+j]) ar[i,j], {i,3}, {j,3}],
β3 // dm[1,2,1]
} // βForm

Simplify[(1/(1+c[1] (Subscript[α, 11])+c[3] (Subscript[α, 31])))((Subscript[α, 11])+c[1] (Subscript[α, 11]^2)+(Subscript[α, 12])+2 c[1] (Subscript[α, 11]) (Subscript[α, 12])+((c[1])^2) (Subscript[α, 11]^2) (Subscript[α, 12])+(Subscript[α, 21])+c[1] (Subscript[α, 11]) (Subscript[α, 21])+c[1] (Subscript[α, 12]) (Subscript[α, 21])+((c[1])^2) (Subscript[α, 11]) (Subscript[α, 12]) (Subscript[α, 21])+(Subscript[α, 22])+2 c[1] (Subscript[α, 11]) (Subscript[α, 22])+((c[1])^2) (Subscript[α, 11]^2) (Subscript[α, 22])+c[1] (Subscript[α, 21]) (Subscript[α, 22])+((c[1])^2) (Subscript[α, 11]) (Subscript[α, 21]) (Subscript[α, 22])+c[3] (Subscript[α, 11]) (Subscript[α, 31])+2 c[3] (Subscript[α, 12]) (Subscript[α, 31])+2 c[1] c[3] (Subscript[α, 11]) (Subscript[α, 12]) (Subscript[α, 31])+c[1] c[3] (Subscript[α, 12]) (Subscript[α, 21]) (Subscript[α, 31])+c[3] (Subscript[α, 22]) (Subscript[α, 31])+c[1] c[3] (Subscript[α, 11]) (Subscript[α, 22]) (Subscript[α, 31])+((c[3])^2) (Subscript[α, 12]) (Subscript[α, 31]^2))]

{
1/2 ar[1,1] // dΔ[1,1,2] // Wheel,
1/2 ar[1,1] // Wheel // dΔ[1,1,2]
} // βForm

{
β1 = W[1]+ a ar[1,1] + b ar[1,2] + c ar[2,1] +d ar[2,2],
β1 // dS[1],
β1 // dA[1],
β1 // dS[1] // dS[2] // FullSimplify,
β1 // dA[1] // dA[2] // FullSimplify
} /. c[s_] :> (Subscript[c, s])// βForm // ColumnForm

The R Matrix

{ρ=F[c[1], c[2]]*ar[1,2], ρ // dS[1] , ρ // dS[2]} // βForm

{(ρ//dS[2])**ρ, (ρ//dS[1])**ρ} // βForm

F must be so that the above vanishes. Here’s a solution:

{((-F[c[1],-c[2]]+F[c[1],c[2]])/(1+c[1] F[c[1],-c[2]])), F[c[1],c[2]]-F[-c[1],c[2]] (1+c[1] F[c[1],c[2]])} /. F[x_, y_] :> (E^x-1)/x // βSimplify

R[i_, j_] := W[1]+ar[i,j](E^c[i]-1)/c[i];
RInv[i_, j_] /; i≠j := R[i,j] // dS[i];
(* R[i, i, p] is R[i,i]^p. Two cases were computed in "120103 Calculator.nb", the rest guessed and checked there. *)
R[i_, i_, p_] := W[1]+((-1+(E^(p*c[i])))/(c[i]))ar[i,i];
RInv[i_, i_] := R[i,i,-1];

{ρ=R[1,2], RInv[1,2], ρ // dS[1] , ρ // dS[2]} // βForm

{R[1,2]**RInv[1,2], R[1,1]**RInv[1,1]}

Rotation by 90 degrees

Rot90[β_] := β // dP[2,1] // dS[1]

Clear[α, β, γ, δ];
{
ρ=W[ω[c[1],c[2]]]+ α[c[1],c[2]] ar[1,1] + β[c[1],c[2]] ar[1,2] + γ[c[1],c[2]] ar[2,1] + δ[c[1],c[2]] ar[2,2],
ρ // dP[1->2, 2->1],
ρ // Rot90,
ρ // Rot90 //Rot90,
ρ // Rot90 // Rot90// Rot90,
ρ // Rot90 // Rot90 // Rot90  // Rot90
} /. c[s_] :> (Subscript[c, s]) // βForm // ColumnForm

R[1,2]**(R[1,2] // dP[1->2, 2->1] // dS[1]// dP[1->2, 2->1]) // βForm

Rotation by 120 degrees

Rot120[β_] := β // dS[2] // dΔ[2,2,3] // dm[1,3,1] // dP[2,1]

{ρ=ar[1,2],
ρ // Rot120,
ρ // Rot120 //Rot120,
ρ // Rot120// Rot120// Rot120
} /. c[s_] :> 0 // βForm // ColumnForm

Clear[α, β, γ, δ];
{
ρ=W[ω[c[1],c[2]]]+ α[c[1],c[2]] ar[1,1] + β[c[1],c[2]] ar[1,2] + γ[c[1],c[2]] ar[2,1] + δ[c[1],c[2]] ar[2,2],
ρ // Rot120,
ρ // Rot120 //Rot120,
ρ // Rot120// Rot120// Rot120
} /. c[s_] :> (Subscript[c, s]) // βForm // ColumnForm

Wheeling and η

{
ρ=Sum[(Subscript[α, 10i+j]) ar[i,j], {i,2}, {j,2}],
ρ // dη[2],
ρ // DeWheel,
ρ // DeWheel // dη[2],
ρ // DeWheel // dη[2] // Wheel
} // βForm // ColumnForm