Pensieve header: The CU definitions.

Startup

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\SL2Portfolio2"];
Once[<< KnotTheory`];
Once[<<"../Profile/Profile.m";];
<<"Engine-Speedy.m";
<<"Objects.m";
$k=2;
HL[ℰ_] := Style[ℰ, Background -> Green];

ρy=(({{0, 0}, {ϵ, 0}}));ρb=(({{0, 0}, {0, -ϵ}}));ρa=(({{γ, 0}, {0, 0}}));ρx=(({{0, γ}, {0, 0}}));
HL/@{ρa.ρx-ρx.ρa==γ ρx, ρa.ρy-ρy.ρa==-γ ρy,ρb.ρy-ρy.ρb==-ϵ ρy, ρb.ρx-ρx.ρb==ϵ ρx,ρx.ρy-ρy.ρx==γ ρb+ϵ ρa}

eq=With[{ME=MatrixExp},ME[ξ0 ρx].ME[η0 ρy]==ME[η1 ρy].ME[β1 ρb].ME[α1 ρa].ME[ξ1 ρx]]

Det /@ eq

{so}=Solve[Thread[Flatten/@eq/.α1->β1 ϵ/γ],{η1,β1,ξ1}]/.C@1->0

eq=With[{ME=MatrixExp},
ME[η1 ρy].ME[β1 ρb].ME[α1 ρa].ME[ξ1 ρx].ME[η2 ρy].ME[β2 ρb].ME[α2 ρa].ME[ξ2 ρx]==ME[η ρy].ME[β ρb].ME[α ρa].ME[ξ ρx]
]

Det /@ eq

{s0}=Solve[PowerExpand/@Log/@Det/@ eq, α]

{s1}=Solve[Thread[Flatten/@eq/.s0],{η,β,ξ}]/.C@1->0

{so}=Solve[Thread[Flatten/@eq/.{}],{η,β,α,ξ}]/.C@1->0

Λ=PowerExpand@Simplify[η y+α a+β b+ξ x/.so]

Q=Limit[Λ,ϵ->0]

Simplify[Λ-Q]

Series[(E^(Λ-Q)),{ϵ,0,2}]

QQ=Q/.{η1->(Subscript[η, i]),β1->(Subscript[β, i]),α1->(Subscript[α, i]),ξ1->(Subscript[ξ, i]),η2->(Subscript[η, j]),β2->(Subscript[β, j]),α2->(Subscript[α, j]),ξ2->(Subscript[ξ, j]),y->(Subscript[y, k]),b->(Subscript[b, k]),a->(Subscript[a, k]),x->(Subscript[x, k])}

QQ/.(Subscript[(η|ξ), _])->0

FullSimplify[Simplify[QQ-(QQ/.(Subscript[(η|ξ), _])->0)]//.l2U]

α2𝒜={(E^(d_.+c_. (Subscript[α, i_]))):>(Subscript[𝒜, i]^(c/γ)) (E^d),(E^(α c_.+d_.)):>(𝒜^(c/γ)) (E^d),(E^(ℰ_)):>(E^(Expand[ℰ//.α2𝒜]))}

FullSimplify[Exp@FullSimplify[Λ-Q]/.{η1->(Subscript[η, i]),β1->(Subscript[β, i]),α1->(Subscript[α, i]),ξ1->(Subscript[ξ, i]),η2->(Subscript[η, j]),β2->(Subscript[β, j]),α2->(Subscript[α, j]),ξ2->(Subscript[ξ, j]),y->(Subscript[y, k]),b->(Subscript[b, k]),a->(Subscript[a, k]),x->(Subscript[x, k])} //.α2𝒜]

Define[(Subscript[cm, i,j->k])=CF@(Subscript[(Subscript[𝔼, {i,j}->{k}])[
(Subscript[a, k]) ((Subscript[α, i])+(Subscript[α, j]))+(Subscript[b, k]) ((Subscript[β, i])+(Subscript[β, j])),
(Subscript[y, k]) ((Subscript[η, i])+((Subscript[η, j])/(Subscript[𝒜, i])))+γ (Subscript[b, k]) (Subscript[η, j]) (Subscript[ξ, i])+(Subscript[x, k]) (((Subscript[ξ, i])/(Subscript[𝒜, j]))+(Subscript[ξ, j])),
(E^((Subscript[y, k]) (Subscript[η, j]) (((E^(-ϵ (Subscript[β, i])))/((Subscript[𝒜, i])+γ ϵ (Subscript[𝒜, i]) (Subscript[η, j]) (Subscript[ξ, i])))-(1/(Subscript[𝒜, i])))+(Subscript[ξ, i]) ((Subscript[x, k]) (((E^(-ϵ (Subscript[β, j])))/((Subscript[𝒜, j])+γ ϵ (Subscript[𝒜, j]) (Subscript[η, j]) (Subscript[ξ, i])))-(1/(Subscript[𝒜, j])))-γ (Subscript[b, k]) (Subscript[η, j])))) (((1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i])))^(((Subscript[a, k])/γ)+((Subscript[b, k])/ϵ)))
], $k])]

(Subscript[cm, 1,2->3])

Timing@Block[{$k=4},HL[((Subscript[cm, 1,2->1])//(Subscript[cm, 1,3->1]))≡((Subscript[cm, 2,3->2])//(Subscript[cm, 1,2->1]))]]

Define[(Subscript[cΔ, i->j,k])=(Subscript[(Subscript[𝔼, {i}->{j,k}])[((Subscript[a, j])+(Subscript[a, k])) (Subscript[α, i])+((Subscript[b, j])+(Subscript[b, k])) (Subscript[β, i]),((Subscript[y, j])+(Subscript[y, k])) (Subscript[η, i])+((Subscript[x, j])+(Subscript[x, k])) (Subscript[ξ, i]),1], $k])]

Associativity, co-associativity, and Δ is an algebra morphism:

Timing@Block[{$k=3},HL /@ {((Subscript[cm, 1,2->1])//(Subscript[cm, 1,3->1]))≡((Subscript[cm, 2,3->2])//(Subscript[cm, 1,2->1])),
((Subscript[cΔ, 1->1,2])//(Subscript[cΔ, 2->2,3]))≡((Subscript[cΔ, 1->1,3])//(Subscript[cΔ, 1->1,2])),
((Subscript[cm, 1,2->1])//(Subscript[cΔ, 1->1,2]))≡(((Subscript[cΔ, 1->1,3])(Subscript[cΔ, 2->2,4]))//((Subscript[cm, 3,4->2])(Subscript[cm, 1,2->1])))}]

Define[(Subscript[cS, i])=(Subscript[𝔼, {i}->{1,2,3,4}])[-(Subscript[β, i])(Subscript[b, 2])-(Subscript[α, i])(Subscript[a, 3]),-(Subscript[η, i])(Subscript[y, 1])-(Subscript[ξ, i])(Subscript[x, 4]),1]//(Subscript[cm, 4,3->i])//(Subscript[cm, i,2->i])//(Subscript[cm, i,1->i])]

S is convolution inverse of id:

Timing@Block[{$k=3},HL[#≡(Subscript[𝔼, {1}->{1}])[0,0,1]]& /@ {
((Subscript[cΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[cS, 1]))~(Subscript[B, 1,2])~(Subscript[cm, 1,2->1]),((Subscript[cΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[cS, 2]))~(Subscript[B, 1,2])~(Subscript[cm, 1,2->1])}]

S is an algebra anti-(co)morphism

Timing@Block[{$k=3},HL/@{(Subscript[cm, 1,2->1])~(Subscript[B, 1])~(Subscript[cS, 1])≡((Subscript[cS, 1])(Subscript[cS, 2]))~(Subscript[B, 1,2])~(Subscript[cm, 2,1->1]), (Subscript[cS, 1])~(Subscript[B, 1])~(Subscript[cΔ, 1->1,2])≡(Subscript[cΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[cS, 1])(Subscript[cS, 2]))}]

Classical is the ℏ->0 limit of quantum:

Timing[HL/@{
((Subscript[cm, 1,2->3]))≡((Limit[#/.U2l,ℏ->0]//.l2U)&/@(Subscript[dm, 1,2->3])),
(Subscript[cΔ, 1->2,3])≡((Limit[#/.U2l,ℏ->0]//.l2U)&/@(Subscript[dΔ, 1->2,3])),
(Subscript[cS, 1])≡((Limit[#/.U2l,ℏ->0]//.l2U)&/@(Subscript[dS, 1]))
}]