Dror Bar-Natan: Talks: Les Diablerets-1708:

Pensieve header: Formulas for “The Dogma is Wrong” talk, Les Diablerets, August 31, 2017.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\LesDiablerets-1708"];

Efficient PBW-like Computations

Goal.

In (𝔤^ϵ)=⟨t,y,a,x⟩/([a,x]=x, [a,y]=-y, [x,y]=t-2ϵ a, [t,*]=0), compute 𝕆((Subscript[y, 1]^3)(Subscript[a, 1]^2)(Subscript[x, 1]^2)(Subscript[y, 2]^2)(Subscript[a, 2]^2)(Subscript[x, 2])|(Subscript[y, 1])(Subscript[a, 1])(Subscript[x, 1])(Subscript[y, 2])(Subscript[a, 2])(Subscript[x, 2])->y a x).

Representing (𝔤^ϵ).

ME=MatrixExp;
Simp[sol_] := Flatten[sol]/. C[_]->0/. (var_->val_) :> (var -> Simplify[PowerExpand@val]);

ρt=(({{1, 0}, {0, 1}}));  ρy=(({{0, 0}, {-ϵ, 0}}));  ρa=(({{(1+1/ϵ)/2, 0}, {0, -(1-1/ϵ)/2}})); ρx=(({{0, 1}, {0, 0}}));
Simplify@{ρa.ρx-ρx.ρa==ρx, ρa.ρy-ρy.ρa==-ρy, ρx.ρy-ρy.ρx==ρt-2ϵ ρa}

eqn=(ME[(Subscript[ξ, 1])ρx].ME[(Subscript[η, 1])ρy]==ME[η0 ρy].ME[λ0(ρt-2ϵ ρa)].ME[ξ0 ρx]);
sol=Simp@Solve[Thread[Flatten/@eqn], {λ0,η0,ξ0}]

The yaxyax formula.

Via (Subscript[t, 1])(Subscript[y, 1])(Subscript[(Subscript[a, 1])[(Subscript[x, 1])(Subscript[t, 2])(Subscript[y, 2])], ->3])(Subscript[a, 2])(Subscript[x, 2])->(Subscript[t, 1])(Subscript[t, 2])(Subscript[t, 3])(Subscript[(Subscript[y, 1])[(Subscript[a, 1])(Subscript[y, 3])], ->4])(Subscript[(Subscript[a, 3])[(Subscript[x, 3])(Subscript[a, 2])], ->5])(Subscript[x, 2])->(Subscript[t, 1])(Subscript[t, 2])(Subscript[t, 3])(Subscript[y, 1])(Subscript[y, 4])(Subscript[a, 4])(Subscript[a, 3])(Subscript[a, 5])(Subscript[x, 5])(Subscript[x, 2])->(Subscript[t, 0])(Subscript[y, 0])(Subscript[a, 0])(Subscript[x, 0]):

eqn3=(ME[(Subscript[ξ, 1])ρx].ME[(Subscript[η, 2])ρy]==ME[η0 ρy].ME[λ0(ρt-2ϵ ρa)].ME[ξ0 ρx]);
sol3=Echo@Simp@Solve[Thread[Flatten/@eqn3], {λ0,η0,ξ0}];
rule3=Simp[{(Subscript[τ, 3])->λ0, (Subscript[η, 3])->η0,(Subscript[α, 3])->-2ϵ λ0,(Subscript[ξ, 3])->ξ0} /. sol3]

eqn4=(ME[(Subscript[α, 1])ρa].ME[(Subscript[η, 3])ρy]==ME[η0 ρy].ME[α0 ρa]);
sol4=Echo@Simp@Solve[Thread[Flatten/@eqn4], {α0,η0}];
rule4=Simp[{(Subscript[η, 4])->η0,(Subscript[α, 4])->α0} /. sol4]

MatrixForm/@eqn4

Thread[Flatten/@eqn4]

Simp@Solve[Thread[Flatten/@eqn4][[1]], {α0}]

Solve[Thread[Flatten/@eqn4] /. Simp@Solve[Thread[Flatten/@eqn4][[1]], {α0}],η0]

rule4=Simp[{(Subscript[η, 4])->η0,(Subscript[α, 4])->α0} /.{α0->(Subscript[α, 1]),η0->(E^(-(Subscript[α, 1]))) (Subscript[η, 3])}]

eqn5=(ME[(Subscript[ξ, 3])ρx].ME[(Subscript[α, 2])ρa]==ME[α0 ρa].ME[ξ0 ρx]);
sol5=Echo@Simp@Solve[Thread[Flatten/@eqn5], {α0,η0}];
rule5=Simp[{(Subscript[η, 5])->η0,(Subscript[α, 5])->α0} /. sol5]

MatrixForm/@eqn5

Thread[Flatten/@eqn5]

Simp@Solve[Thread[Flatten/@eqn5][[1]], {α0}]

Thread[Flatten/@eqn5] /. Simp@Solve[Thread[Flatten/@eqn5][[1]], α0]

Solve[Thread[Flatten/@eqn5] /. Simp@Solve[Thread[Flatten/@eqn5][[1]], {α0}],ξ0]

rule5=Simp[{(Subscript[ξ, 5])->ξ0,(Subscript[α, 5])->α0} /. {α0->(Subscript[α, 2]), ξ0->(E^(-(Subscript[α, 2]))) (Subscript[ξ, 3])}]

yaxyaxrule=Simp[{(Subscript[τ, 0])->(Subscript[τ, 1])+(Subscript[τ, 2])+(Subscript[τ, 3]), (Subscript[η, 0])->(Subscript[η, 1])+(Subscript[η, 4]),(Subscript[α, 0])->(Subscript[α, 4])+(Subscript[α, 3])+(Subscript[α, 5]), (Subscript[ξ, 0])->(Subscript[ξ, 5])+(Subscript[ξ, 2])} /. rule5 /. rule4 /. rule3]

Series[{(Subscript[τ, 0]),(Subscript[η, 0]),(Subscript[α, 0]),(Subscript[ξ, 0])} /. yaxyaxrule, {ϵ,0,1}]

ME=MatrixExp;
Simplify[
ME[(Subscript[τ, 1])ρt].ME[(Subscript[η, 1])ρy].ME[(Subscript[α, 1])ρa].ME[(Subscript[ξ, 1])ρx].ME[(Subscript[τ, 2]) ρt].ME[(Subscript[η, 2])ρy].ME[(Subscript[α, 2])ρa].ME[(Subscript[ξ, 2])ρx]==ME[(Subscript[τ, 0]) ρt].ME[(Subscript[η, 0])ρy].ME[(Subscript[α, 0])ρa].ME[(Subscript[ξ, 0])ρx] /. {(Subscript[τ, 0])->-((Log[1-ϵ (Subscript[η, 2]) (Subscript[ξ, 1])])/ϵ)+(Subscript[τ, 1])+(Subscript[τ, 2]),(Subscript[η, 0])->(Subscript[η, 1])+(((E^(-(Subscript[α, 1]))) (Subscript[η, 2]))/(1-ϵ (Subscript[η, 2]) (Subscript[ξ, 1]))),(Subscript[α, 0])->2 Log[1-ϵ (Subscript[η, 2]) (Subscript[ξ, 1])]+(Subscript[α, 1])+(Subscript[α, 2]),(Subscript[ξ, 0])->(((E^(-(Subscript[α, 2]))) (Subscript[ξ, 1]))/(1-ϵ (Subscript[η, 2]) (Subscript[ξ, 1])))+(Subscript[ξ, 2])}]

D[(E^((Subscript[τ, 0])t+(Subscript[η, 0])y+(Subscript[α, 0])a+(Subscript[ξ, 0])x))/.yaxyaxrule, {(Subscript[η, 1]),3}] /. (Subscript[(τ|η|α|ξ), 1|2])->0

D[(E^((Subscript[τ, 0])t+(Subscript[η, 0])y+(Subscript[α, 0])a+(Subscript[ξ, 0])x))/.yaxyaxrule, {(Subscript[η, 1]),3},{(Subscript[α, 1]),2},{(Subscript[ξ, 1]),2}] /. (Subscript[(τ|η|α|ξ), 1|2])->0

Expand[D[(E^((Subscript[τ, 0])t+(Subscript[η, 0])y+(Subscript[α, 0])a+(Subscript[ξ, 0])x))/.yaxyaxrule, {(Subscript[η, 1]),3},{(Subscript[α, 1]),2},{(Subscript[ξ, 1]),2},{(Subscript[η, 2]),4}] /. (Subscript[(τ|η|α|ξ), 1|2])->0]

Expand[D[(E^((Subscript[τ, 0])t+(Subscript[η, 0])y+(Subscript[α, 0])a+(Subscript[ξ, 0])x))/.yaxyaxrule, {(Subscript[η, 1]),3},{(Subscript[α, 1]),2},{(Subscript[ξ, 1]),2},{(Subscript[η, 2]),2},{(Subscript[α, 2]),2},{(Subscript[ξ, 2]),1}] /. (Subscript[(τ|η|α|ξ), 1|2])->0]

Expand[(∂_({(Subscript[η, 1]),3}))(∂_({(Subscript[α, 1]),2}))(∂_({(Subscript[ξ, 1]),2}))(∂_({(Subscript[η, 2]),2}))(∂_({(Subscript[α, 2]),2}))(∂_({(Subscript[ξ, 2]),1}))((E^((Subscript[τ, 0])t+(Subscript[η, 0])y+(Subscript[α, 0])a+(Subscript[ξ, 0])x))/.yaxyaxrule) /. (Subscript[(τ|η|α|ξ), 1|2])->0]

Expand[(∂_({(Subscript[η, 1]),3}))(∂_({(Subscript[α, 1]),2}))(∂_({(Subscript[ξ, 1]),2}))(∂_({(Subscript[η, 2]),2}))(∂_({(Subscript[α, 2]),2}))(∂_({(Subscript[ξ, 2]),1}))Exp[
(-((Log[1-ϵ (Subscript[η, 2]) (Subscript[ξ, 1])])/ϵ)+(Subscript[τ, 1])+(Subscript[τ, 2]))t+((Subscript[η, 1])+(((E^(-(Subscript[α, 1]))) (Subscript[η, 2]))/(1-ϵ (Subscript[η, 2]) (Subscript[ξ, 1]))))y+(2 Log[1-ϵ (Subscript[η, 2]) (Subscript[ξ, 1])]+(Subscript[α, 1])+(Subscript[α, 2]))a+((((E^(-(Subscript[α, 2]))) (Subscript[ξ, 1]))/(1-ϵ (Subscript[η, 2]) (Subscript[ξ, 1])))+(Subscript[ξ, 2]))x
] /. (Subscript[(τ|η|α|ξ), 1|2])->0]

Exporting the above as PDF files

The below is adapted from pensieve://Talks/NCSU-1604/GaussGassnerDemo.nb.

ConditionalExport[fname_String, rest___] := Module[{temp, exists},
temp="ConditionalExportTemporary"<>"."<>FileExtension[fname];
exists=FileExistsQ[fname];
Export[temp, rest];
If[exists && FileByteCount[fname]===FileByteCount[temp],
DeleteFile[temp],
(* else *) Print["Exporting "<>fname<>"..."];
If[exists, DeleteFile[fname]];
RenameFile[temp, fname]
];
fname
]

SetOptions[$FrontEndSession,PrintingStyleEnvironment->"Working"];
TagProperties[_] := {};
TagProperties["131"] = {PageWidth ->3.2/0.66};
Options[CellExport] = {
PageWidth -> 4/0.66, CellFilter -> Identity, ExportDirectory -> "Snips", ExportBaseFilename -> Automatic, ExportFormat -> ".pdf", ExportOptions -> {}, Split -> False
};
CellExport[tag_String, opts___Rule] := CellExport[
NotebookGet[EvaluationNotebook[]],
tag, opts
];
CellExport[nb_Notebook, tag_String] := CellExport[nb, tag, TagProperties[tag]];
CellExport[nb_Notebook, tag_String, OptionsPattern[]] := Module[
{cells, cell, filename, format},
filename = FileNameJoin[{
OptionValue[ExportDirectory] /. Automatic -> Directory[],
OptionValue[ExportBaseFilename] /. Automatic -> tag
}];
format=OptionValue[ExportFormat];
cells=OptionValue[CellFilter][Cases[
nb, c_Cell /; FreeQ[List@@c, Cell] && !FreeQ[c, CellTags->tag],
Infinity
]];
If[!OptionValue[Split],
If[Length[cells]≥1,
If[Length[cells]==1,
cells=Join[First[cells], Cell[PageWidth ->1.2 72OptionValue[PageWidth], Background->{White, Opacity[0]}]],
cells=Cell[CellGroup[cells], PageWidth -> 72OptionValue[PageWidth]]
];
ConditionalExport[
filename<>format,cells,
ImageResolution -> 300,
OptionValue[ExportOptions]
]
],
k=0;
Table[
++k;
ConditionalExport[
filename<>"-"<>ToString[k]<>format,
Append[cell, PageWidth -> 72OptionValue[PageWidth]],
ImageResolution -> 300,
OptionValue[ExportOptions]
],
{cell, cells}
]
]
];

ExportCells:=(
nb=NotebookGet[EvaluationNotebook[]];
tags=Cases[nb, (CellTags->tag_String) :> tag, Infinity ] // Union;
Print[tags];
CellExport /@ tags;
Print["Done."]
);

ExportCells