Pensieve header: Notebook for DBN Lecture 3 in Matemale, April 2018. See http://www.math.toronto.edu/~drorbn/Talks/Matemale-1804/.

Today. First Dror, then Roland.

Unrelated Question. Anybody wants a French (azerty) keyboard for a surface pro?

Before we Start...

Please think about our Partial To do List!

Recall the Zipping Formula...

... and that we only need to compute operations on exponentials...

Our Algebra QU

QU=⟨y,a,x,t⟩, with t central and subject to the relations [a,x]=γ x, [a,y]=-γ y, and x y-q y x=((1-T (A^2))/ℏ), where q=(e^(ℏ γ ϵ)), T=(e^(ℏ t)) (t=ϵ a-γ b, as Roland derived the algebra), and A=(e^(-ℏ ϵ a)). For convenience we set 𝒜=(e^(γ α)).

QU has a co-product Δ and an antipode S given by

Δ(y,a,x,t) = ((Subscript[y, 1])+(Subscript[T, 1])(Subscript[y, 2])(Subscript[A, 1]), (Subscript[a, 1])+(Subscript[a, 2]), (Subscript[x, 1])+(Subscript[A, 1])(Subscript[x, 2]))

S(y,a,x,t) = (-(T^(-1))(A^(-1))y, -a, -(A^(-1))x, -t)

The Program

Initialization / Utilities

$p=2; $k=1; $U=QU; $E:={$k,$p};
$trim:={(ℏ^(p_.))/;p>$p->0, (ϵ^(k_.))/;k>$k->0};
(Subscript[q, ℏ])=(E^(γ ϵ ℏ));
T2t={(Subscript[T, i_]^(p_.))->(E^(p ℏ (Subscript[t, i]))),(T^(p_.))->(E^(p ℏ t))};
t2T={(E^(c_.(Subscript[t, i_])+b_.)):>(Subscript[T, i]^(c/ℏ))(E^b),(E^(c_.t+b_.)):>(T^(c/ℏ))(E^b),(E^(ℰ_)):>(E^(Expand@ℰ))}; 
SetAttributes[SS,HoldAll];
SS[ℰ_,op_]:=Collect[
Normal@Series[If[$p>0,ℰ,ℰ/.T2t],{ℏ,0,$p}],
ℏ,op];
SS[ℰ_]:=SS[ℰ,Together];
Simp[ℰ_,op_]:=Collect[ℰ,_CU|_QU,op];
Simp[ℰ_]:=Simp[ℰ,SS[#,Expand]&];
Kδ/:(Subscript[Kδ, i_,j_]):=If[i===j,1,0];
(Subscript[c_Integer, k_Integer]) := c+((O[ϵ])^(k+1));

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

Unprotect[SeriesData];
SeriesData /: CF[sd_SeriesData] := MapAt[CF,sd,3];
SeriesData /: Expand[sd_SeriesData] := MapAt[Expand,sd,3];
SeriesData /: Simplify[sd_SeriesData] := MapAt[Simplify,sd,3];
SeriesData /: Together[sd_SeriesData] := MapAt[Together,sd,3];
SeriesData /: Collect[sd_SeriesData,specs__] := MapAt[Collect[#,specs]&,sd,3];
Protect[SeriesData];

DeclareAlgebra

Unprotect[NonCommutativeMultiply]; Attributes[NonCommutativeMultiply]={};
(NCM=NonCommutativeMultiply)[x_] := x;
NCM[x_,y_,z__] := (x**y)**z;
0**_=_**0=0;
(x_Plus)**y_:=(#**y)&/@x; x_**(y_Plus):=(x**#)&/@y;
B[x_,x_]=0; B[x_,y_] := x**y-y**x;
B[x_,y_,e_]:=B[x,y,e]=B[x,y];

DeclareAlgebra[U_Symbol, opts__Rule] := Module[{gp,sr,g,cp,M,CE,k=0,
gs=Generators /. {opts},
cs=Centrals /. {opts} /. Centrals -> {} },
((Subscript[#, U])=U@#)&/@gs;
gp=Alternatives@@gs; gp=gp|(Subscript[gp, _]);(* gens *)
sr=Flatten@Table[{g->++k, (Subscript[g, i_])->{i,k}},{g,gs}]; (* sorting -> *) 
cp=Alternatives@@cs; (* cents *)
SetAttributes[M,HoldRest]; M[0,_]=0; M[a_,x_]:=a x;
CE[ℰ_]:=Collect[ℰ,_U,Expand]/.$trim;
(Subscript[U, i_])[ℰ_]:=ℰ/.{t:cp:>(Subscript[t, i]),u_U:>((Subscript[#, i])&)/@u};
(Subscript[U, i_])[NCM[]]=U@{}=(Subscript[1, U])=U[];
B[U@(Subscript[(x_), i_]),U@(Subscript[(y_), i_])]:=(Subscript[U, i])@B[U@x,U@y];
B[U@(Subscript[(x_), i_]),U@(Subscript[(y_), j_])] /; i=!=j := 0;
B[U@y_,U@x_]:=CE[-B[U@x,U@y]];
x_**(c_.(Subscript[1, U])):=CE[c x]; (c_.(Subscript[1, U]))**x_:=CE[c x];
(a_.U[xx___,x_])**(b_.U[y_,yy___]) :=If[OrderedQ[{x,y}/.sr],
CE@M[a b/.$trim,U[xx,x,y,yy]],
U@xx**CE@M[a b/.$trim,U@y**U@x+B[U@x,U@y,$E]]**U@yy ];
U@{c_.*(((l:gp))^(n_)),r___}/;FreeQ[c, gp]:= CE[c U@Table[l,{n}]**U@{r}];
U@{c_.*l:gp,r___} := CE[c U[l]**U@{r}];
U@{c_,r___}/;FreeQ[c, gp]:= CE[c U@{r}];
U@{l_Plus, r___} := CE[U@{#,r}& /@ l];
U@{l_,r___} := U@{Expand[l],r};
U[ℰ_NonCommutativeMultiply]:=U/@ℰ; 
(Subscript[𝕆, U])[specs___,poly_] := Module[{sp,null,vs,us},
sp=Replace[{specs}, l_List:>(Subscript[l, null]), {1}];
vs=Join@@(First /@ sp);
us=Join@@(sp /. (Subscript[l_, s_]) :> (l/.(Subscript[x_, i_]):>(Subscript[x, s])));
CE[Total[
CoefficientRules[poly, vs] /. (p_->c_) :> c U@((us^p))
]] /. (Subscript[x_, null]):>x];
(Subscript[𝕆, U])[specs___,𝔼[L_,Q_,P_]]:=(Subscript[𝕆, U])[specs,SS@Normal[P (E^(L+Q))]];
(Subscript[σ, rs___])[c_.*u_U] := (c/.(Subscript[(t:cp), j_]):>(Subscript[t, j/.{rs}]))U[List@@(u/.(Subscript[v_, j_]):>(Subscript[v, j/.{rs}]))];
(Subscript[m, j_->k_])[c_.*u_U] := CE[((c/.(Subscript[(t:cp), j])->(Subscript[t, k]))DeleteCases[u,(Subscript[_, j|k])])**U@@Cases[u,(Subscript[w_, j]):>(Subscript[w, k])]**U@@Cases[u,(Subscript[_, k])]];
U /: c_.*u_U*v_U := CE[c u**v];
(Subscript[S, i_])[c_.*u_U]:= CE[((c/.(Subscript[S, i])[U,Centrals])DeleteCases[u,(Subscript[_, i])])**(Subscript[U, i])[NCM@@Reverse@Cases[u,(Subscript[x_, i]):>S@U@x]]];
(Subscript[Δ, i_->j_,k_])[c_.*u_U]:= CE[((c/.(Subscript[Δ, i->j,k])[U,Centrals])DeleteCases[u,(Subscript[_, i])])**(NCM@@Cases[u,(Subscript[x_, i]):>(Subscript[σ, 1->j,2->k])@Δ@U@x] /. NCM[]->U[])]; ]

DeclareMorphism

DeclareMorphism[m_,U_->V_, ongs_List, oncs_List:{}] := (
Replace[ongs, {(g_->img_) :> (m[U[g]]=img),(g_:>img_) :> (m[U[g]]:=img/.$trim)}, {1}];
m[(Subscript[1, U])]=(Subscript[1, V]);
m[U[(Subscript[g_, i_])]] := (Subscript[V, i])[m[U@g]];
m[U[vs__]] := NCM@@(m/@U/@{vs});
m[ℰ_] := Simp[ℰ /. oncs /.  u_U:>m[u]] /. $trim; )

Meta-Operations

(Subscript[σ, rs___])[ℰ_Plus] := (Subscript[σ, rs])/@ℰ;
(Subscript[m, j_->j_])=Identity; (Subscript[m, j_->k_])[0] = 0;
(Subscript[m, j_->k_])[ℰ_Plus] := Simp[(Subscript[m, j->k])/@ℰ];
(Subscript[m, is___,i_,j_->k_])[ℰ_]:=(Subscript[m, j->k])@(Subscript[m, is,i->j])@ℰ;
(Subscript[S, i_])[ℰ_Plus] := Simp[(Subscript[S, i])/@ℰ];
(Subscript[Δ, is___])[ℰ_Plus] := Simp[(Subscript[Δ, is])/@ℰ];

Implementing CU=𝒰((Subscript[sl, 2]^(γϵ)))

DeclareAlgebra[CU,Generators->{y,a,x},Centrals->{t}];
B[(Subscript[a, CU]),(Subscript[y, CU])]=-γ (Subscript[y, CU]); B[(Subscript[x, CU]),(Subscript[a, CU])]=-γ (Subscript[x, CU]);
B[(Subscript[x, CU]),(Subscript[y, CU])]=2ϵ (Subscript[a, CU])-t (Subscript[1, CU]);
(S@(Subscript[y, CU])=-(Subscript[y, CU]); S@(Subscript[a, CU])=-(Subscript[a, CU]); S@(Subscript[x, CU])=-(Subscript[x, CU]);)
(Subscript[S, i_])[CU,Centrals]={(Subscript[t, i])->-(Subscript[t, i])};
Δ@(Subscript[y, CU])=CU@(Subscript[y, 1])+CU@(Subscript[y, 2]); Δ@(Subscript[a, CU])=CU@(Subscript[a, 1])+CU@(Subscript[a, 2]); Δ@(Subscript[x, CU])=CU@(Subscript[x, 1])+CU@(Subscript[x, 2]);
(Subscript[Δ, i_->j_,k_])[CU,Centrals]={(Subscript[t, i])->(Subscript[t, j])+(Subscript[t, k])};

Implementing QU=(Subscript[𝒰, q])((Subscript[sl, 2]^(γϵ)))

DeclareAlgebra[QU, Generators -> {y,a,x}, Centrals -> {t,T}];
B[(Subscript[a, QU]),(Subscript[y, QU])]=-γ (Subscript[y, QU]); B[(Subscript[x, QU]),(Subscript[a, QU])]=-γ QU@x;
B[(Subscript[x, QU]),(Subscript[y, QU])]:=SS[(Subscript[q, ℏ])-1]QU@{y,x}+(Subscript[𝕆, QU])[{a},SS[(1-T (E^(-2ϵ a ℏ)))/ℏ]];
(S@(Subscript[y, QU]):=(Subscript[𝕆, QU])[{a,y},SS[-(T^(-1))(E^(ℏ ϵ a))y]]; S@(Subscript[a, QU])=-(Subscript[a, QU]); S@(Subscript[x, QU]):=(Subscript[𝕆, QU])[{a,x},SS[-(E^(ℏ ϵ a))x]];)
(Subscript[S, i_])[QU,Centrals]={(Subscript[t, i])->-(Subscript[t, i]), (Subscript[T, i])->(Subscript[T, i]^(-1))};
Δ@(Subscript[y, QU]):=(Subscript[𝕆, QU])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1])}, 1]),(Subscript[{(Subscript[y, 2])}, 2]),SS[(Subscript[y, 1])+(Subscript[T, 1])(E^(-ℏ ϵ (Subscript[a, 1])))(Subscript[y, 2])]]; Δ@(Subscript[a, QU])=QU@(Subscript[a, 1])+QU@(Subscript[a, 2]); Δ@(Subscript[x, QU]):=(Subscript[𝕆, QU])[(Subscript[{(Subscript[a, 1]),(Subscript[x, 1])}, 1]),(Subscript[{(Subscript[x, 2])}, 2]),SS[(Subscript[x, 1])+(E^(-ℏ ϵ (Subscript[a, 1])))(Subscript[x, 2])]];
(Subscript[Δ, i_->j_,k_])[QU,Centrals]={(Subscript[t, i])->(Subscript[t, j])+(Subscript[t, k]),(Subscript[T, i])->(Subscript[T, j])(Subscript[T, k])};

The representation ρ

ρ@(Subscript[y, CU])=ρ@(Subscript[y, QU])=(({{0, 0}, {ϵ, 0}}));ρ@(Subscript[a, CU])=ρ@(Subscript[a, QU])=(({{γ, 0}, {0, 0}}));
ρ@(Subscript[x, CU])=(({{0, γ}, {0, 0}})); ρ@(Subscript[x, QU])=(({{0, (1-(E^(-γ ϵ ℏ)))/(ϵ ℏ)}, {0, 0}}));
ρ[(E^(ℰ_))]:=MatrixExp[ρ[ℰ]];
ρ[ℰ_]:=(ℰ/.T2t/.t->γ ϵ/.(U:CU|QU)[u___]:>Fold[Dot,(({{1, 0}, {0, 1}})),ρ/@U/@{u}])

tSW

Goal. In either U, compute F=(e^(-ηy))(e^(ξx))(e^(ηy))(e^(-ξx)). First compute G=(e^(ξx))((ye)^(-ξx)), a finite sum. Now F satisfies the ODE (∂_η)F=(∂_η)((e^(-ηy))(e^(ηG)))=-yF+FG with initial conditions F(η=0)=1. So we set it up and solve:

(Subscript[SW, xy])[U_,kk_] :=  (Subscript[SW, xy])[U,kk] =Block[{$U=U,$k=kk,$p=kk},Module[{G,F,fs,f,bs,e,b,es},
G=Simp[Table[(ξ^k)/k!, {k,0, $k+1}].NestList[Simp[B[(Subscript[x, U]) ,# ]]&, (Subscript[y, U]), $k+1]];
fs=Flatten@Table[(Subscript[f, l,i,j,k])[η],{l,0,$k},{i,0, l},{j,0, l},{k,0, l}];
F=fs.(bs=fs/.(Subscript[f, l_,i_,j_,k_])[η]:>(ϵ^l)U@{(y^i),(a^j),(x^k)});
es=Flatten[Table[Coefficient[e,b]==0,{e,{F-(Subscript[1, U])/.η->0,F**G-(Subscript[y, U])**F-(∂_η)F}},{b,bs}]];
F=F/.DSolve[es,fs,η][[1]];
𝔼[0,
ξ x+η y+(U /. {CU->-t η ξ, QU-> η ξ(1-T)/ℏ}),
F+(Subscript[0, $k])/.{(E^(_))->1,U->Times}
] /. (v:η|ξ|t|T|y|a|x)->(Subscript[v, 1])
]];
(Subscript[tSW, xy_,i_,j_->k_]):=(Subscript[SW, xy])[$U,$k] /. {(Subscript[ξ, 1])->(Subscript[ξ, i]),(Subscript[η, 1])->(Subscript[η, j]),(Subscript[(v:t|T|y|a|x), 1])->(Subscript[v, k])};
(Subscript[tSW, xa,i_,j_->k_]):=𝔼[(Subscript[α, j])(Subscript[a, k]),(E^(-γ (Subscript[α, j])))(Subscript[ξ, i])(Subscript[x, k]),1];
(Subscript[tSW, ay,i_,j_->k_]):=𝔼[(Subscript[α, i])(Subscript[a, k]),(E^(-γ (Subscript[α, i])))(Subscript[η, j])(Subscript[y, k]),1];

Exponentials as needed.

Task. Define  (Subscript[Exp, (Subscript[U, i]),k])[ξ,P] which computes (e^(ξ 𝕆(P))) to (ϵ^k) in the algebra (Subscript[U, i]), where ξ is a scalar, X is (Subscript[x, i]) or (Subscript[y, i]), and P is an ϵ-dependent near-docile element, giving the answer in 𝔼-form. Should satisfy U@(Subscript[Exp, (Subscript[U, i]),k])[ξ,P] == (Subscript[𝕊, U])[(e^(ξ x)), x->𝕆(P)].
Methodology. If (Subscript[P, 0]):=(Subscript[P, ϵ=0]) and (e^(ξ 𝕆(P)))=𝕆((e^(ξ (Subscript[P, 0])))F(ξ)), then F(ξ=0)=1 and we have:
𝕆((e^(ξ (Subscript[P, 0])))((Subscript[P, 0])F(ξ)+(∂_ξ)F)=𝕆((∂_ξ)(e^(ξ (Subscript[P, 0])))F(ξ))=(∂_ξ)𝕆((e^(ξ (Subscript[P, 0])))F(ξ))=(∂_ξ)(e^(ξ 𝕆(P)))=(e^(ξ 𝕆(P)))𝕆(P)=𝕆((e^(ξ (Subscript[P, 0])))F(ξ))𝕆(P).
This is an ODE for F. Setting inductively (Subscript[F, k])=(Subscript[F, k-1])+(ϵ^k)φ we find that (Subscript[F, 0])=1 and solve for φ.

(* Bug: The first line is valid only if 𝕆((E^(Subscript[P, 0])))==(E^(𝕆((Subscript[P, 0])))). *)
(* Bug: ξ must be a symbol. *)
(Subscript[Exp, (Subscript[U_, i_]),0])[ξ_,P_]:=Module[{LQ=Normal@P /. ϵ->0},
𝔼[ξ LQ/.(Subscript[(x|y), i])->0, ξ LQ/.(Subscript[(t|a), i])->0,1] ];
(Subscript[Exp, (Subscript[U_, i_]),k_])[ξ_,P_]:=Block[{$U=U,$k=k},
Module[{P0,φ,φs,F,j,rhs,at0,atξ},
P0=Normal@P /. ϵ->0;
φs=Flatten@Table[(Subscript[φ, j1,j2,j3])[ξ],{j2,0,k},{j1,0,2k+1-j2},{j3,0,2k+1-j2-j1}];
F=Normal@Last@(Subscript[Exp, (Subscript[U, i]),k-1])[ξ,P]+(ϵ^k)φs.(φs/.(Subscript[φ, js__])[ξ]:>Times@@(({(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])})^({js})));
rhs=Normal@Last@(Subscript[m, i,j->i])[𝔼[ξ P0/.(Subscript[(x|y), i])->0,ξ P0/.(Subscript[(t|a), i])->0, F+(Subscript[0, k])](Subscript[m, i->j])@𝔼[0,0,P+(Subscript[0, k])]];
at0=(#==0)& /@ Flatten@CoefficientList[F-1 /. ξ->0, {(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}];
atξ=(#==0)& /@ Flatten@CoefficientList[((∂_ξ)F)+P0 F-rhs, {(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}];
𝔼[ξ P0/.(Subscript[(x|y), i])->0,ξ P0/.(Subscript[(t|a), i])->0, F+(Subscript[0, k])] /. DSolve[And@@(at0⋃atξ),φs,ξ][[1]] ]]

Zip and Bind

𝔼/:𝔼[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];

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

(Subscript[Zip, {}])[P_]:=P; (Subscript[Zip, {ζ_,ζs___}])[P_] := (Expand[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. For QZip, the z’s are (Subscript[x, i]) and (Subscript[η, i]) and the ζ’s are (Subscript[ξ, i]) and (Subscript[y, i]).

(Subscript[QZip, ζs_List,simp_])@𝔼[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;
simp /@ 𝔼[L,Q2,Det[qt](E^(-Q2))(Subscript[Zip, ζs])[(E^Q1)(P/.zrule)]] ];
(Subscript[QZip, ζs_List]):=(Subscript[QZip, ζs,CF]);

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 (Subscript[t, i]) and (Subscript[α, i]) and the ζ’s are (Subscript[τ, i]) and (Subscript[a, i]).

(Subscript[LZip, ζs_List,simp_])@𝔼[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/.T2t/.zrule)/.Alternatives@@zs->0;
simp /@ 𝔼[L2,Q2,Det[lt](E^(-L2-Q2))(Subscript[Zip, ζs])[(E^(L1+Q1))(P/.T2t/.zrule)]]//.t2T ];
(Subscript[LZip, ζs_List]):=(Subscript[LZip, ζs,CF]);

(Subscript[Bind, {}])[L_,R_]:=L R;
(Subscript[Bind, {is__}])[L_𝔼,R_𝔼] := Module[{n},
Times[
L/.Table[(Subscript[(v: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, Flatten@Table[{(Subscript[τ, n@i]),(Subscript[a, n@i])},{i,{is}}]]) // (Subscript[QZip, Flatten@Table[{(Subscript[ξ, n@i]),(Subscript[y, n@i])},{i,{is}}]]) ];
(Subscript[B, l_List]):=(Subscript[Bind, l]); (Subscript[B, is___]):=(Subscript[Bind, {is}]);
Bind[ℰ_𝔼] := ℰ;
Bind[Ls__,ζs_List,R_] := (Subscript[Bind, ζs])[Bind[Ls],R];

Tensorial Representations

tη=t𝟙=𝔼[0,0,1+(Subscript[0, $k])];

(Subscript[tm, i_,j_->k_]):=Module[{tk},
𝔼[((Subscript[τ, i])+(Subscript[τ, j]))(Subscript[t, k])+(Subscript[α, i])(Subscript[a, k])+(Subscript[α, j])(Subscript[a, k]),(Subscript[η, i])(Subscript[y, k])+(Subscript[ξ, j])(Subscript[x, k]),1]((Subscript[tSW, xy,i,j->tk]) /. {(Subscript[t, tk])->(Subscript[t, k]),(Subscript[T, tk])->(Subscript[T, k]),(Subscript[y, tk])->(E^(-γ (Subscript[α, i])))(Subscript[y, k]),(Subscript[a, tk])->(Subscript[a, k]),(Subscript[x, tk])->(E^(-γ (Subscript[α, j])))(Subscript[x, k])})];
(Subscript[m, j_->k_])[ℰ_𝔼]:=ℰ~(Subscript[B, j,k])~(Subscript[tm, j,k->k]);

S[U_,kk_]:=S[U,kk]=Module[{OE},
OE=(Subscript[m, 3,2,1->1])[(Subscript[Exp, (Subscript[QU, 1]),$k])[η,(Subscript[S, 1])[QU[(Subscript[y, 1])]]/.QU->Times](Subscript[Exp, (Subscript[QU, 2]),$k])[α,(Subscript[S, 2])[QU[(Subscript[a, 2])]]/.QU->Times](Subscript[Exp, (Subscript[QU, 3]),$k])[ξ,(Subscript[S, 3])[QU[(Subscript[x, 3])]]/.QU->Times]];
𝔼[-(Subscript[t, 1])(Subscript[τ, 1])+OE[[1]], OE[[2]],OE[[3]]] /.{η->(Subscript[η, 1]),α->(Subscript[α, 1]),ξ->(Subscript[ξ, 1])}];
(Subscript[tS, i_]):=S[$U,$k]/.{(Subscript[(v:τ|η|α|ξ), 1])->(Subscript[v, i]),(Subscript[(v:t|T|y|a|x), 1])->(Subscript[v, i])};

Δ[U_,kk_]:=Δ[U,kk]=Module[{OE},
OE=Block[{$k=kk,$p=kk+1},(Subscript[m, 1,3,5->1])@(Subscript[m, 2,4,6->2])@Times[ (* Warning: wrong unless $p≥$k+1! *)
ReplacePart[1->0]@(Subscript[Exp, (Subscript[QU, 1]),$k])[η,(Subscript[Δ, 1->1,2])[QU[(Subscript[y, 1])]]/.QU->Times],
ReplacePart[2->0]@(Subscript[Exp, (Subscript[QU, 3]),$k])[α,(Subscript[Δ, 3->3,4])[QU[(Subscript[a, 3])]]/.QU->Times],
ReplacePart[1->0]@(Subscript[Exp, (Subscript[QU, 5]),$k])[ξ,(Subscript[Δ, 5->5,6])[QU[(Subscript[x, 5])]]/.QU->Times]
] /. {η->(Subscript[η, 1]), α->(Subscript[α, 1]), ξ->(Subscript[ξ, 1])}];
𝔼[(Subscript[τ, 1])((Subscript[t, 1])+(Subscript[t, 2]))+(Subscript[α, 1])((Subscript[a, 1])+(Subscript[a, 2])), OE[[2]],OE[[3]]]];
(Subscript[tΔ, i_->j_,k_]):=Δ[$U,$k] /. {(Subscript[(v:τ|η|α|ξ), 1])->(Subscript[v, i]),(Subscript[(v:t|T|y|a|x), 1])->(Subscript[v, j]),(Subscript[(v:t|T|y|a|x), 2])->(Subscript[v, k])};

The Faddeev-Quesne formula:

(Subscript[E, q_,k_])[x_]:=E^((∑_(j=1)^(k+1)) (((((1-q))^j)(x^j))/(j(1-(q^j))))); (Subscript[E, q_])[x_]:=(Subscript[E, q,$k])[x]

R[QU,kk_]:=R[QU,kk]=𝔼[-((ℏ (Subscript[a, 2]) (Subscript[t, 1]))/γ), ℏ (Subscript[x, 2]) (Subscript[y, 1]),Series[(E^(ℏ (γ^(-1))(Subscript[t, 1])(Subscript[a, 2])-ℏ (Subscript[y, 1])(Subscript[x, 2])))((E^(ℏ (Subscript[b, 1])(Subscript[a, 2])))(Subscript[E, (Subscript[q, ℏ]),kk])[ℏ (Subscript[y, 1])(Subscript[x, 2])]/.(Subscript[b, 1])->(γ^(-1))(ϵ (Subscript[a, 1])-(Subscript[t, 1]))), {ϵ,0,kk}]] ;
(Subscript[tR, i_,j_]):=R[$U,$k] /. {(Subscript[(v:t|T|y|a|x), 1])->(Subscript[v, i]),(Subscript[(v:t|T|y|a|x), 2])->(Subscript[v, j])};
(Subscript[(OverBar[tR]), i_,j_]):=(Subscript[(OverBar[tR]), i,j])=(Subscript[tR, i,j])~(Subscript[B, j])~(Subscript[tS, j]);

tC is the counterclockwise spinner; (OverBar[tC]) is its inverse.

(Subscript[tC, i_]):=𝔼[0,0,(Subscript[T, i]^(1/2))(E^(-ϵ (Subscript[a, i])ℏ ))+(Subscript[0, $k])];
(Subscript[(OverBar[tC]), i_ ]):=𝔼[0,0,(Subscript[T, i]^(-1/2))(E^(ϵ (Subscript[a, i])ℏ ))+(Subscript[0, $k])];

Kink[QU,kk_]:= Kink[QU,kk]=Block[{$k=kk},((Subscript[tR, 1,3])(Subscript[(OverBar[tC]), 2]))~(Subscript[B, 1,2])~(Subscript[tm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[tm, 1,3->1])];
(Subscript[tKink, i_]):=Kink[$U,$k]/.{(Subscript[(v:t|T|y|a|x), 1])->(Subscript[v, i])};
(OverBar[Kink])[QU,kk_]:= (OverBar[Kink])[QU,kk]=Block[{$k=kk},((Subscript[(OverBar[tR]), 1,3])(Subscript[tC, 2]))~(Subscript[B, 1,2])~(Subscript[tm, 1,2->1])~(Subscript[B, 1,3])~(Subscript[tm, 1,3->1])];
(Subscript[(OverBar[tKink]), i_]):=(OverBar[Kink])[$U,$k]/.{(Subscript[(v:t|T|y|a|x), 1])->(Subscript[v, i])}

Alternative Algorithms

(Subscript[λ, alt,k_])[CU]:=If[k==0,1,Module[{eq,d,b,c,so},
eq=ρ@(E^(ξ (Subscript[x, CU]))).ρ@(E^(η (Subscript[y, CU])))==ρ@(E^(d (Subscript[y, CU]))).ρ@(E^(c(t (Subscript[1, CU]) - 2ϵ (Subscript[a, CU])))).ρ@(E^(b (Subscript[x, CU])));
{so}=Solve[Thread[Flatten/@eq],{d,b,c}]/.C@1->0;
Series[(E^(-η y-ξ x+η ξ t+c t + d y - 2ϵ c a + b x))/.so,{ϵ,0,k}]]];

New Utilities (not on handout)

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

Some Runs

The Structure Tensors

$k=1; γ=1;

(Subscript[tm, 1,2->3]) //. α2𝒜

But that’s not the form we like! Let’s open Zip and Bind!

How was it computed? Let’s open the tSW box!

(Subscript[tS, 1])

How was it computed? Let’s open Exponentials as Needed!

(Subscript[tΔ, 1->1,2])

{(Subscript[tR, 1,2]), (Subscript[(OverBar[tR]), 1,2])}

{(Subscript[tC, 1]),(Subscript[(OverBar[tC]), 2])}

Some Testing

Associativity of tm.

(Subscript[tm, 1,2->2])~(Subscript[B, 2])~(Subscript[tm, 2,3->1])

(Subscript[tm, 1,2->fran])~(Subscript[B, fran])~(Subscript[tm, fran,3->1])≡(Subscript[tm, 2,3->2])~(Subscript[B, 2])~(Subscript[tm, 1,2->1])

tS is an anti-homomorphism for tm.

((Subscript[tS, 1])(Subscript[tS, 2]))~(Subscript[B, 1,2])~(Subscript[tm, 1,2->1])≡(Subscript[tm, 2,1->1])~(Subscript[B, 1])~(Subscript[tS, 1])

Testing convolution inverse:

(Subscript[tΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[tS, 1])~(Subscript[B, 1,2])~(Subscript[tm, 1,2->1])

Testing quasi-triangular axioms

((Subscript[tΔ, 1->1,2])(Subscript[tR, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tm, 1,3->1])(Subscript[tm, 2,4->2]))≡((Subscript[tΔ, 1->2,1])(Subscript[tR, 3,4]))~(Subscript[B, 1,2,3,4])~((Subscript[tm, 3,1->1])(Subscript[tm, 4,2->2]))

Testing R3

((Subscript[tR, 2,3])(Subscript[tR, 1,4])(Subscript[tR, 5,6]))~(Subscript[B, 1,2,3,4,5,6])~((Subscript[tm, 1,5->1])(Subscript[tm, 2,6->2])(Subscript[tm, 3,4->3]) )≡((Subscript[tR, 1,2])(Subscript[tR, 5,3])(Subscript[tR, 6,4]))~(Subscript[B, 1,2,3,4,5,6])~((Subscript[tm, 1,5->1])(Subscript[tm, 2,6->2])(Subscript[tm, 3,4->3]) )

Docility and why it matters:

In our case our invariants and operations are of the form (e^(L+Q))P, where

L is a quadratic of the form ∑(Subscript[l, zζ])zζ, where z runs over (Subscript[{(Subscript[t, i]),(Subscript[α, i])}, i∈S]) and ζ runs over (Subscript[{(Subscript[τ, i]),(Subscript[a, i])}, i∈S]), with integer coefficients (Subscript[l, zζ]).

Q is a quadratic of the form ∑(Subscript[q, zζ])zζ, where z runs over (Subscript[{(Subscript[x, i]),(Subscript[η, i])}, i∈S]) and ζ runs over (Subscript[{(Subscript[ξ, i]),(Subscript[y, i])}, i∈S]), with coefficients (Subscript[q, zζ]) in the ring (Subscript[R, s]) of rational functions in (Subscript[((Subscript[T, i])), i∈S]) and (Subscript[((Subscript[𝒜, i])), i∈S]).

P=∑(ϵ^k)(Subscript[P, k]) is a docile power series in (Subscript[{(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i]),(Subscript[η, i]),(Subscript[ξ, i])}, i∈S]), where deg((Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i]),(Subscript[η, i]),(Subscript[ξ, i]))=(1,2,1,1,1).

The Trefoil

Seeing that our invariant is poly-time and the trefoil knot is tiny, the following will compute in no time at all:

Timing@Block[{$k=1},
Z=(Subscript[tR, 1,5])(Subscript[tR, 6,2])(Subscript[tR, 3,7])(Subscript[(OverBar[tC]), 4])(Subscript[(OverBar[tKink]), 8])(Subscript[(OverBar[tKink]), 9])(Subscript[(OverBar[tKink]), 10]);
Do[Z=Z~(Subscript[B, 1,k])~(Subscript[tm, 1,k->1]),{k,2,10}]; Z]

Timing@Block[{$k=1},
Z=(Subscript[tR, 1,5])(Subscript[tR, 6,2])(Subscript[tR, 3,7])(Subscript[(OverBar[tC]), 4])(Subscript[(OverBar[tKink]), 8])(Subscript[(OverBar[tKink]), 9])(Subscript[(OverBar[tKink]), 10]) /. (Subscript[T, _])->(Subscript[T, 1]);
Do[Z=Z~(Subscript[B, 1,k])~(Subscript[tm, 1,k->1])/. (Subscript[T, _])->(Subscript[T, 1]),{k,2,10}]; Z]