Pensieve header: Derived from pensieve://Projects/SL2Invariant/Archive/nb/SL2Invariant-180811.pdf.

Program

Internal Utilities

Canonical Form:

CF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[
Expand[ℰ] //. (E^(x_))(E^(y_)):>(E^(x+y)) /. (E^(x_)):>(E^(CF[x]))];

The Kronecker δ:

Kδ/:(Subscript[Kδ, i_,j_]):=If[i===j,1,0];

Equality, multiplication, and degree-adjustment of perturbed Gaussians; 𝔼[L,Q,P] stands for (e^(L+Q))P:

𝔼/:𝔼[L1_,Q1_,P1_]≡𝔼[L2_,Q2_,P2_]:=CF[L1==L2]∧CF[Q1==Q2]∧CF[Normal[P1-P2]==0];
𝔼/:𝔼[L1_,Q1_,P1_]𝔼[L2_,Q2_,P2_]:=𝔼[L1+L2,Q1+Q2,P1*P2];

Zip and Bind

Variables and their duals:

{(SuperStar[t]),(SuperStar[b]),(SuperStar[y]),(SuperStar[a]),(SuperStar[x]),(SuperStar[z])}={τ,β,η,α,ξ,ζ}; 
{(SuperStar[τ]),(SuperStar[β]),(SuperStar[η]),(SuperStar[α]),(SuperStar[ξ]),(SuperStar[ζ])}={t,b,y,a,x,z}; (SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]);

Finite Zips:

collect[ℰ_,ζ_] := Collect[ℰ,ζ];
(Subscript[Zip, {}])[P_]:=P; (Subscript[Zip, {ζ_,ζs___}])[P_] := 
(collect[P//(Subscript[Zip, {ζs}]),ζ] /. f_.(ζ^(d_.)):>(∂_({(SuperStar[ζ]),d}))f) /. (SuperStar[ζ])->0

QZip implements the “Q-level zips” on 𝔼(L,Q,P)=((Pe)^(L+Q)). Such zips regard the L variables as scalars.

(Subscript[QZip, ζs_List])@𝔼[L_,Q_,P_] := Module[{ζ,z,zs,c,ys,ηs,qt,zrule,Q1,Q2},
zs=Table[(SuperStar[ζ]),{ζ,ζs}];
c=Q/.Alternatives@@(ζs⋃zs)->0;
ys=Table[(∂_ζ)(Q/.Alternatives@@zs->0),{ζ,ζs}];
ηs=Table[(∂_z)(Q/.Alternatives@@ζs->0),{z,zs}];
qt=Inverse@Table[(Subscript[Kδ, z,(SuperStar[ζ])])-(∂_(z,ζ))Q,{ζ,ζs},{z,zs}];
zrule=Thread[zs->qt.(zs+ys)];
Q2=(Q1=c+ηs.zs/.zrule)/.Alternatives@@zs->0;
CF /@ 𝔼[L,Q2,Det[qt](E^(-Q2))(Subscript[Zip, ζs])[(E^Q1)(P/.zrule)]] ];

Upper to lower and lower to Upper:

U2l={(Subscript[B, i_]^(p_.))->(E^(-p ℏ γ (Subscript[b, i]))),(B^(p_.))->(E^(-p ℏ γ b)), (Subscript[T, i_]^(p_.))->(E^(p ℏ (Subscript[t, i]))),(T^(p_.))->(E^(p ℏ t)),(Subscript[𝒜, i_]^(p_.))->(E^(p γ (Subscript[α, i]))),(𝒜^(p_.))->(E^(p γ α))}; 
l2U={(E^(c_.(Subscript[b, i_])+d_.)):>(Subscript[B, i]^(-c/(ℏ γ)))(E^d),(E^(c_.b+d_.)):>(B^(-c/(ℏ γ)))(E^d),
(E^(c_.(Subscript[t, i_])+d_.)):>(Subscript[T, i]^(c/ℏ))(E^d),(E^(c_.t+d_.)):>(T^(c/ℏ))(E^d),
(E^(c_.(Subscript[α, i_])+d_.)):>(Subscript[𝒜, i]^(c/γ))(E^d),(E^(c_.α+d_.)):>(𝒜^(c/γ))(E^d),
(E^(ℰ_)):>(E^(Expand@ℰ))};

LZip implements the “L-level zips” on 𝔼(L,Q,P)=((Pe)^(L+Q)). Such zips regard all of ((Pe)^Q) as a single”P”. Here the z’s are b and α and the ζ’s are β and a.

(Subscript[LZip, ζs_List])@𝔼[L_,Q_,P_] := Module[{ζ,z,zs,c,ys,ηs,lt,zrule,L1,L2,Q1,Q2},
zs=Table[(SuperStar[ζ]),{ζ,ζs}];
c=L/.Alternatives@@(ζs⋃zs)->0;
ys=Table[(∂_ζ)(L/.Alternatives@@zs->0),{ζ,ζs}];
ηs=Table[(∂_z)(L/.Alternatives@@ζs->0),{z,zs}];
lt=Inverse@Table[(Subscript[Kδ, z,(SuperStar[ζ])])-(∂_(z,ζ))L,{ζ,ζs},{z,zs}];
zrule=Thread[zs->lt.(zs+ys)];
L2=(L1=c+ηs.zs/.zrule)/.Alternatives@@zs->0;
Q2=(Q1=Q/.U2l/.zrule)/.Alternatives@@zs->0;
CF /@ 𝔼[L2,Q2,Det[lt](E^(-L2-Q2))(Subscript[Zip, ζs])[(E^(L1+Q1))(P/.U2l/.zrule)]]//.l2U ];

(Subscript[B, {}])[L_,R_]:=L R;
(Subscript[B, {is__}])[L_𝔼,R_𝔼] := Module[{n},
Times[
L/.Table[(Subscript[(v:b|B|t|T|a|x|y), i])->(Subscript[v, n@i]),{i,{is}}],
R/.Table[(Subscript[(v:β|τ|α|𝒜|ξ|η), i])->(Subscript[v, n@i]),{i,{is}}]
] // (Subscript[LZip, Join@@Table[{(Subscript[β, n@i]),(Subscript[τ, n@i]),(Subscript[a, n@i])},{i,{is}}]]) // (Subscript[QZip, Join@@Table[{(Subscript[ξ, n@i]),(Subscript[y, n@i])},{i,{is}}]]) ];
(Subscript[B, is___])[L_,R_]:=(Subscript[B, {is}])[L,R];

(Subscript[m, i_,j_->k_]):=𝔼[(Subscript[a, k]) (Subscript[α, i])+(Subscript[a, k]) (Subscript[α, j])+(Subscript[b, k]) (Subscript[β, i])+(Subscript[b, k]) (Subscript[β, j]),(1/(ℏ (Subscript[𝒜, i]) (Subscript[𝒜, j])))(ℏ (Subscript[y, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j]) (Subscript[η, i])+ℏ (Subscript[y, k]) (Subscript[𝒜, j]) (Subscript[η, j])+ℏ (Subscript[x, k]) (Subscript[𝒜, i]) (Subscript[ξ, i])+(Subscript[𝒜, i]) (Subscript[𝒜, j]) (Subscript[η, j]) (Subscript[ξ, i])-(Subscript[B, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j]) (Subscript[η, j]) (Subscript[ξ, i])+ℏ (Subscript[x, k]) (Subscript[𝒜, i]) (Subscript[𝒜, j]) (Subscript[ξ, j])),1];
(Subscript[R, i_,j_]):=𝔼[ℏ (Subscript[a, j]) (Subscript[b, i]),ℏ (Subscript[x, j]) (Subscript[y, i]),1];
(Subscript[(OverBar[R]), i_,j_]):=𝔼[-ℏ (Subscript[a, j]) (Subscript[b, i]),-((ℏ (Subscript[x, j]) (Subscript[y, i]))/(Subscript[B, i])),1];
(Subscript[S, i_]):=𝔼[-(Subscript[a, i]) (Subscript[α, i])-(Subscript[b, i]) (Subscript[β, i]),(1/(ℏ (Subscript[B, i])))(-ℏ (Subscript[y, i]) (Subscript[𝒜, i]) (Subscript[η, i])-ℏ (Subscript[B, i]) (Subscript[x, i]) (Subscript[𝒜, i]) (Subscript[ξ, i])+(Subscript[𝒜, i]) (Subscript[η, i]) (Subscript[ξ, i])-(Subscript[B, i]) (Subscript[𝒜, i]) (Subscript[η, i]) (Subscript[ξ, i])),1];
(Subscript[Δ, i_->j_,k_]):=𝔼[(Subscript[a, j]) (Subscript[α, i])+(Subscript[a, k]) (Subscript[α, i])+(Subscript[b, j]) (Subscript[β, i])+(Subscript[b, k]) (Subscript[β, i]),(Subscript[y, j]) (Subscript[η, i])+(Subscript[B, j]) (Subscript[y, k]) (Subscript[η, i])+(Subscript[x, j]) (Subscript[ξ, i])+(Subscript[x, k]) (Subscript[ξ, i]),1];
(Subscript[C, i_]):=𝔼[0,0,(Subscript[B, i]^(1/2))];
(Subscript[(OverBar[C]), i_]):=𝔼[0,0,(Subscript[B, i]^(-1/2))];

(Subscript[Kink, i_]) := ((Subscript[R, 1,3])(Subscript[(OverBar[C]), 2]))~(Subscript[B, 1,2])~(Subscript[m, 1,2->1])~(Subscript[B, 1,3])~(Subscript[m, 1,3->i]);
(Subscript[(OverBar[Kink]), i_]) := ((Subscript[(OverBar[R]), 1,3])(Subscript[C, 2]))~(Subscript[B, 1,2])~(Subscript[m, 1,2->1])~(Subscript[B, 1,3])~(Subscript[m, 1,3->i]);

Testing

HL[ℰ_] := Style[ℰ, Background -> Yellow];

(co)-associativity

HL/@{((Subscript[Δ, 1->1,2])~(Subscript[B, 2])~(Subscript[Δ, 2->2,3]))≡((Subscript[Δ, 1->1,3])~(Subscript[B, 1])~(Subscript[Δ, 1->1,2])),((Subscript[m, 1,2->1])~(Subscript[B, 1])~(Subscript[m, 1,3->1]))≡((Subscript[m, 2,3->2])~(Subscript[B, 2])~(Subscript[m, 1,2->1]))}

Δ is an algebra morphism

HL[(Subscript[m, 1,2->1])~(Subscript[B, 1])~(Subscript[Δ, 1->1,2])≡((Subscript[Δ, 1->1,3])(Subscript[Δ, 2->2,4]))~(Subscript[B, 1,2,3,4])~((Subscript[m, 3,4->2])(Subscript[m, 1,2->1]))]

(Subscript[S, 2]) inverts R, but not (Subscript[S, 1]):

{(Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[S, 1])≡(Subscript[(OverBar[R]), 1,2]), HL[(Subscript[R, 1,2])~(Subscript[B, 2])~(Subscript[S, 2])≡(Subscript[(OverBar[R]), 1,2])]}

S is convolution inverse of id

HL[#≡𝔼[0,0,1]]& /@ {((Subscript[Δ, 1->1,2])~(Subscript[B, 1])~(Subscript[S, 1]))~(Subscript[B, 1,2])~(Subscript[m, 1,2->1]),((Subscript[Δ, 1->1,2])~(Subscript[B, 2])~(Subscript[S, 2]))~(Subscript[B, 1,2])~(Subscript[m, 1,2->1])}

S is a (co)-algebra anti-morphism

HL/@Expand/@{(Subscript[m, 1,2->1])~(Subscript[B, 1])~(Subscript[S, 1])≡((Subscript[S, 1])(Subscript[S, 2]))~(Subscript[B, 1,2])~(Subscript[m, 2,1->1]),(Subscript[S, 1])~(Subscript[B, 1])~(Subscript[Δ, 1->1,2])≡(Subscript[Δ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[S, 1])(Subscript[S, 2]))}

Quasi-triangular axiom 1:

HL[(Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[Δ, 1->1,3])≡((Subscript[R, 1,4])(Subscript[R, 3,2]))~(Subscript[B, 2,4])~(Subscript[m, 2,4->2])]

Quasi-triangular axiom 2:

HL[(((Subscript[Δ, 1->1,2])(Subscript[R, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[m, 1,3->1])(Subscript[m, 2,4->2])))≡(((Subscript[Δ, 1->2,1])(Subscript[R, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[m, 3,1->1])(Subscript[m, 4,2->2])))]

HL/@{((Subscript[C, i])(Subscript[(OverBar[C]), j]))~(Subscript[B, i,j])~(Subscript[m, i,j->i])≡𝔼[0,0,1],((Subscript[(OverBar[C]), i])(Subscript[(OverBar[C]), j]))~(Subscript[B, i,j])~(Subscript[m, i,j->i])≡((((Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[S, 1])~(Subscript[B, 1,2])~(Subscript[m, 2,1->i]))~(Subscript[B, i])~(Subscript[S, i]))((Subscript[R, 1,2])~(Subscript[B, 2])~(Subscript[S, 2])~(Subscript[B, 2])~(Subscript[S, 2])~(Subscript[B, 1,2])~(Subscript[m, 2,1->j])))~(Subscript[B, i,j])~(Subscript[m, i,j->i])}

Reidemeister 2:

HL[#≡𝔼[0,0,1]]&/@{((Subscript[(OverBar[R]), 1,2])(Subscript[R, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[m, 1,3->1])(Subscript[m, 2,4->2])),((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[m, 1,3->1])(Subscript[m, 2,4->2]))}

Cyclic Reidemeister 2:

HL[((Subscript[R, 1,4])(Subscript[(OverBar[R]), 5,2])(Subscript[(OverBar[C]), 3]))~(Subscript[B, 2,4])~(Subscript[m, 2,4->2])~(Subscript[B, 1,3])~(Subscript[m, 1,3->1])~(Subscript[B, 1,5])~(Subscript[m, 1,5->1])≡(Subscript[(OverBar[C]), 1])]

Reidemeister 3:

HL[(((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6]))~(Subscript[B, 1,4])~(Subscript[m, 1,4->1])~(Subscript[B, 2,5])~(Subscript[m, 2,5->2])~(Subscript[B, 3,6])~(Subscript[m, 3,6->3]) )≡(((Subscript[R, 1,6])(Subscript[R, 2,3])(Subscript[R, 4,5]))~(Subscript[B, 1,4])~(Subscript[m, 1,4->1])~(Subscript[B, 2,5])~(Subscript[m, 2,5->2])~(Subscript[B, 3,6])~(Subscript[m, 3,6->3]))]

The Trefoil

Z=(Subscript[R, 1,5])(Subscript[R, 6,2])(Subscript[R, 3,7])(Subscript[(OverBar[C]), 4])(Subscript[(OverBar[Kink]), 8])(Subscript[(OverBar[Kink]), 9])(Subscript[(OverBar[Kink]), 10]);
Do[Z=Z~(Subscript[B, 1,r])~(Subscript[m, 1,r->1]),{r,2,10}];
Simplify/@Z