Pensieve header: Demo for the package FreeLie`. More at http://www.math.toronto.edu/~drorbn/Talks/LesDiablerets-1508/

Note: The web root for my “Academic Pensieve” is http://drorbn.net/AcademicPensieve/. The packages FreeLie` and AwCalculus` are at http://drorbn.net/AcademicPensieve/Projects/WKO4/.

path="C:/drorbn/AcademicPensieve/";SetDirectory[path<>"2015-08/LesDiablerets-1508"];
Get[path<>"Projects/WKO4/FreeLie.m"];
Get[path<>"Projects/WKO4/AwCalculus.m"];
x=LW@"x"; y=LW@"y"; u=LW@"u";
$SeriesShowDegree = 6;

BCH[x, y]  (* Can raise degree to 22 *)

{F=LS[{x,y}, Fs], G=LS[{x,y}, Gs]}; Fs["y"]=1/2;
SeriesSolve[{F,G},
(ℏ^(-1))(LS[x+y]-BCH[y,x]≡F-G-Ad[-x][F]+Ad[y][G])∧(Subscript[div, x])[F]+(Subscript[div, y])[G]≡(1/2)(Subscript[tr, u])[adSeries[(ad/((E^ad)-1)), x][u]+adSeries[(ad/((E^ad)-1)), y][u]-adSeries[(ad/((E^ad)-1)), BCH[x,y]][u]]];
{F,G}  (* Can raise degree to 13 *)

{b[F,G], (Subscript[tr, x])[F]}

;;
α=LS[{x,y}, αs]; β=LS[{x,y}, βs];γ=CWS[{x,y}, γs];
V=Es[⟨x->α, y->β⟩, γ];
κ=CWS[{x}, κs]; Cap=Es[⟨x->LS[0]⟩,κ];
Rs[a_,b_]:= Es[⟨a->LS[0], b->LS[LW@a]⟩, CWS[0]];
R4Eqn=V**(Rs[x,z] // dΔ[x,x,y]) ≡ Rs[y,z]**Rs[x,z]**V ;UnitarityEqn=(V**(V//dA) ≡ Es[⟨x->LS[0], y->LS[0]⟩,CWS[0]]);
CapEqn=((V**(Cap//dΔ[x,x,y])//dc[x]//dc[y]) ≡ (Cap(Cap//dσ[x,y])//dc[x]//dc[y]));
βs["x"]= 1/2; βs["y"]=0;
SeriesSolve[{α, β,γ, κ}, ((ℏ^(-1))R4Eqn) ∧ UnitarityEqn ∧ CapEqn];
{V, κ}

logF = Λ[V][[1]]  // dσ[{x,y}->{y,x}];
logF // EulerE // adSeries[(((E^ad)-1)/ad), logF, tb]

Φs[2,1]=Φs[3,1]=Φs[3,2]=0;Φs[3,1,2]=1/24; Φ=DKS[3, Φs];
SeriesSolve[Φ, ((Φ^(σ[3,2,1]))≡-Φ)∧(Φ**(Φ^(σ[1,23,4]))**(Φ^(σ[2,3,4]))≡(Φ^(σ[12,3,4]))**(Φ^(σ[1,2,34])))];
Φ (* Can raise degree to 10 *)

R=DKS[t[1,2]/2];
(Subscript[Z, B]) = (((-Φ))^(σ[13,2,4]))**(Φ^(σ[1,3,2]))**(R^(σ[2,3]))**(((-Φ))^(σ[1,2,3]))**(Φ^(σ[12,3,4]));
(Subscript[Z, B])@{4}

(El[(Subscript[Z, B]) // αMap[1,2,3,4], CWS[0]] // Γ// ((tη)^1) // ((tη)^3) // ((hη)^2) // ((hη)^4)//hσ[{3}->{2}]//tσ[{2,4}->{1,2}])[[1]]

Rs[a_,b_]:= Es[⟨a->LS[0], b->LS[LW@a]⟩, CWS[0]];
iRs[a_,b_]:= Es[⟨a->LS[0], b->-LS[LW@a]⟩, CWS[0]];
ζ= iRs[r,6]Rs[2,4]iRs[g,9]Rs[5,7]iRs[b,3]Rs[8,1];
({{Do[ζ = ζ // dm[r,k,r], {k,1,3}];
Do[ζ = ζ // dm[g,k,g], {k,4,6}];
Do[ζ = ζ // dm[b,k,b], {k,7,9}];
{(Subscript[ζ[[1]], r])@{5}, ζ[[2]]@{5}} // Print, }});

The below is adapted from pensieve://Projects/WKO4/CellExport.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["Initialization"] = {PageWidth -> 8};
TagProperties["VCapSolution"] = {PageWidth -> 7};
TagProperties["Borromean"] = {PageWidth -> 6.6};
Options[CellExport] = {
PageWidth -> 6.28, CellFilter -> Identity, 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 = 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=Append[First[cells], PageWidth -> 72OptionValue[PageWidth]],
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}
]
]
];
nb=NotebookGet[EvaluationNotebook[]];
tags=Cases[nb, (CellTags->tag_) :> tag, Infinity ] // Union;
CellExport /@ tags