Pensieve header: Calculations appearing in the WKO4 paper.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\WKO4"];

Section 1 - Introduction

<< FreeLie.m;
<< AwCalculus.m;
$SeriesShowDegree=4;

Section 2.2 - Some Preliminaries on Lie Algebras and Cyclic Words

(Subscript[x, 1])=LW[1]; (Subscript[x, 2])=LW[2];
{α,β,γ} = LS /@ {(Subscript[x, 1])+b[(Subscript[x, 1]),(Subscript[x, 2])], (Subscript[x, 2])-b[(Subscript[x, 1]),b[(Subscript[x, 1]),(Subscript[x, 2])]], (Subscript[x, 1])+(Subscript[x, 2])-2b[(Subscript[x, 1]),(Subscript[x, 2])]}

{b[α,β], b[α,b[β,γ]]+b[β,b[γ,α]]+b[γ,b[α,β]]}

bch=BCH[LW@x,LW@y]

Timing@{Length@(bch@16), (bch@16)[[1090;;1092]] // TopBracketForm}

{(Subscript[ω, 1]),(Subscript[ω, 2])} = CWS /@ {CW["1"]-3CW["211"],  CW["2"]+CW["22"]}

DegreeScale[h] /@ {(Subscript[ω, 1]),(Subscript[ω, 2])}

{λ=⟨1->α, 2 -> β⟩, γ // (Subscript[D, λ])}

λ1=λ; λ2=⟨1->β, 2 -> γ⟩; tb[λ1,λ2]

lhs=(Subscript[D, tb[λ1,λ2]])[(Subscript[ω, 1])]; rhs=b[(Subscript[D, λ1]),(Subscript[D, λ2])][(Subscript[ω, 1])];
{lhs@{8}, (lhs≡rhs)@{8}}

lhs=(∂_t)(Subscript[Γ, t])[λ]; rhs=λ // (E^(-t (Subscript[D, λ]))) // adSeries[(ad/((E^ad)-1)), (Subscript[Γ, t])[λ]];
{(Subscript[Γ, 0])[λ], lhs, (lhs≡rhs)@{6}}

{γ // (E^(-t (Subscript[D, λ]))), γ // CC[(Subscript[Γ, t])[λ]]}

lhs=(∂_t)(Subscript[Λ, t])[λ]; rhs=λ // (E^(Subscript[D, (Subscript[Λ, t])[λ]])) // adSeries[(ad/((E^ad)-1)), (Subscript[Λ, t])[λ], tb];
{(Subscript[Λ, 0])[λ], lhs, (lhs≡rhs)@{6}}

{γ // CC[t λ], γ // (E^(-(Subscript[D, (Subscript[Λ, t])[λ]])))}

{α // (Subscript[CC, 1])[-γ], α // (Subscript[CC, 1])[-γ] // (Subscript[RC, 1])[γ], α // (Subscript[CC, 1])[-γ] // (Subscript[CC, 1])[γ]}

With[{γ=LW@u+b[b[LW@v,LW@u],LW@u]}, (Subscript[div, u])[γ]] // TopBracketForm

(Subscript[J, 1])[γ]

{div[λ]@{5}, j[λ]@{5}}

lhs=j[(Subscript[BCH, tb])[λ1, λ2]]; rhs=j[λ1] + (E^(Subscript[D, λ1]))[j[λ2]];
{lhs, (lhs≡rhs)@{8}}

lhs=j[(Subscript[BCH, b])[λ1, λ2]]; rhs=j[λ1] + (E^(Subscript[D, λ1]))[j[λ2]];
{lhs, (lhs≡rhs)}

ϵ /: (ϵ^2)=0;
{j[ϵ λ], j[ϵ λ]≡ϵ div[λ]}

Section 2.3 - The [AT]-inspired presentation (Subscript[E, l]) of (Subscript[(A^w), exp])

(Subscript[x, 1])=LW[1]; (Subscript[x, 2])=LW[2];
{(Subscript[ζ, a])=(Subscript[E, l])[⟨1->LS[(Subscript[x, 1])+b[(Subscript[x, 1]),(Subscript[x, 2])]], 2->LS[(Subscript[x, 2])-b[(Subscript[x, 1]),b[(Subscript[x, 1]),(Subscript[x, 2])]]]⟩, CWS[CW["1"]-3CW["121"]]],
(Subscript[ζ, b])=(Subscript[E, l])[⟨1->LS[(Subscript[x, 2])-b[(Subscript[x, 1]),(Subscript[x, 2])]], 2->LS[(Subscript[x, 1])+(Subscript[x, 2])+b[(Subscript[x, 2]),b[(Subscript[x, 1]),(Subscript[x, 2])]]]⟩, CWS[CW["2"]-2CW["12"]]],
(Subscript[ζ, c])=(Subscript[E, l])[⟨1->LS[(Subscript[x, 1])-b[b[(Subscript[x, 1]),(Subscript[x, 2])],b[(Subscript[x, 1]),(Subscript[x, 2])]]], 2->LS[(Subscript[x, 2])+3b[(Subscript[x, 1]),b[(Subscript[x, 1]),(Subscript[x, 2])]]]⟩, CWS[CW["1"]-2CW["12"]+CW["121"]]]}

lhs=(Subscript[ζ, a])**((Subscript[ζ, b])**(Subscript[ζ, c])); rhs=((Subscript[ζ, a])**(Subscript[ζ, b]))**(Subscript[ζ, c]);
{lhs@{3}, (lhs≡rhs)@{8}}

{(Subscript[ζ, a]) // ((dη)^1), (Subscript[ζ, a]) // ((dη)^2)}

{(Subscript[ζ, d])=(Subscript[E, l])[λ, CWS[0]], (Subscript[ζ, d]) // dA}

((Subscript[ζ, d]) ≡ ((Subscript[ζ, d])//dA//dA))@{8}

lhs=((Subscript[ζ, a])**(Subscript[ζ, b]))//dA; rhs=((Subscript[ζ, b])//dA)**((Subscript[ζ, a])//dA);
{lhs@{3}, (lhs≡rhs)@{8}}

(Subscript[ζ, d]) // dS

{(Subscript[ζ, a]), (Subscript[ζ, a])//dΔ[2,2,3]}

lhs=((Subscript[ζ, a])**(Subscript[ζ, b]))//dΔ[2,2,3]; rhs=((Subscript[ζ, a])//dΔ[2,2,3])**((Subscript[ζ, b])//dΔ[2,2,3]);
{lhs@{3}, (lhs≡rhs)@{8}}

Section 2.4 - The factored presentation (Subscript[E, f]) of (Subscript[(A^w), exp]) and its stronger precursor (Subscript[E, s])

u=LW@u; v=LW@v;
(Subscript[ξ, a])=(Subscript[E, s])[⟨1->LS[u+b[u,v]], 2->LS[v-b[u,b[u,v]]], 3->LS[u-b[b[u,v],b[u,v]]]⟩, CWS[CW["u"]-3CW["uvu"]]]

SeedRandom[0]; (Subscript[ξ, b])=(Subscript[E, s])[⟨Table[i->RandomLieSeries[{1,2,3,4}], {i,4}]⟩, RandomCWSeries[{1,2,3,4}]];
(Subscript[ξ, b])@{2}

lhs=(Subscript[ξ, a]) // hm[1,2,4] // tha[u,4]; rhs=(Subscript[ξ, a]) // tha[u,1] // tha[u,2] // hm[1,2,4];
{lhs, (lhs≡rhs)@{8}}

lhs=(Subscript[ξ, b]) // dm[1,2,1] // dm[1,3,1]; rhs=(Subscript[ξ, b]) // dm[2,3,2] // dm[1,2,1];
{lhs@{3}, (lhs≡rhs)@{5}}

Section 3.1 - Tangle Invariants

Section 3.1.1 - The General Framework

(Subscript[R, t:(l|s)]^(+))[a_,b_] := (Subscript[E, t])[⟨a->LS[0], b->LS[LW@a]⟩, CWS[0]];
(Subscript[R, t:(l|s)]^(-))[a_,b_] := (Subscript[E, t])[⟨a->LS[0], b->-LS[LW@a]⟩, CWS[0]];

lhs=(Subscript[R, l]^(+))[1,2]**(Subscript[R, l]^(+))[1,3]**(Subscript[R, l]^(+))[2,3]; rhs=(Subscript[R, l]^(+))[2,3]**(Subscript[R, l]^(+))[1,3]**(Subscript[R, l]^(+))[1,2];
{lhs@{3}, (lhs≡rhs)@{5}}

Section 3.1.2 - The Knot (Subscript[8, 17]) and the Borromean Tangle

t1=(Subscript[R, s]^(-))[12,1](Subscript[R, s]^(-))[2,7](Subscript[R, s]^(-))[8,3](Subscript[R, s]^(-))[4,11](Subscript[R, s]^(+))[16,5](Subscript[R, s]^(+))[6,13](Subscript[R, s]^(+))[14,9](Subscript[R, s]^(+))[10,15];
Do[t1 = t1 // dm[1,k,1], {k,2,16}];t1@{6}

t2= (Subscript[R, s]^(-))[r,6](Subscript[R, s]^(+))[2,4](Subscript[R, s]^(-))[g,9](Subscript[R, s]^(+))[5,7](Subscript[R, s]^(-))[b,3](Subscript[R, s]^(+))[8,1];
(Do[t2 = t2 // dm[r,k,r], {k,1,3}]; Do[t2 = t2 // dm[g,k,g], {k,4,6}];
Do[t2 = t2 // dm[b,k,b], {k,7,9}];  t2)

Section 3.2 - Solutions of the Kashiwara-Vergne Equations

Continues pensieve://2013-10/SolvingWKO.nb.

α=LS[{"1","2"}, αs]; β=LS[{"1","2"}, βs];γ=CWS[{"1","2"}, γs];
V=(Subscript[E, s])[⟨1->α, 2->β⟩, γ];

κ=CWS[{"1"}, κs]; Cap=Es[⟨1->LS[0]⟩,κ];

R4Eqn=((Subscript[R, s]^(+))[2,3]**(Subscript[R, s]^(+))[1,3]**V ≡ V**((Subscript[R, s]^(+))[1,3] // dΔ[1,1,2]));UnitarityEqn=(V**(V//dA[1]//dA[2]) ≡ (Subscript[E, s])[⟨1->LS[0], 2->LS[0]⟩,CWS[0]]);
CapEqn=((V**(Cap//dΔ[1,1,2])//dc[1]//dc[2]) ≡ (Cap(Cap//dσ[1,2])//dc[1]//dc[2]));

αs["1"]= 0; αs["2"]=-1/2;
SeriesSolve[{α, β,γ, κ}, (ℏ^(-1))R4Eqn && UnitarityEqn && CapEqn];
{V, κ}

{F=LS[{x,y}, fs], G=LS[{x,y}, gs]};
SeriesSolve[{F,G},
(ℏ^(-1))(LS[LW@x+LW@y]-BCH[LW@y,LW@x]≡F-G-Ad[-LW@x][F]+Ad[LW@y][G])
&& (Subscript[div, x])[F]+(Subscript[div, y])[G]≡(1/2)(Subscript[tr, LW@u])[adSeries[(ad/((E^ad)-1)), LW@x][LW@u]+adSeries[(ad/((E^ad)-1)), LW@y][LW@u]-adSeries[(ad/((E^ad)-1)), BCH[LW@x,LW@y]][LW@u]]
]

kv=⟨1->F,2->G⟩

at=V[[1]] // dσ[{1,2}->{2,1}];
atkv=at // EulerE // adSeries[(((E^ad)-1)/ad), at] // RC[-at] // LieMorphism[LW@1->LW@x, LW@2->LW@y]

at1 = at // Λ ;
atkv1=at1 // EulerE // adSeries[(((E^ad)-1)/ad), at1, tb] // LieMorphism[LW@1->LW@x, LW@2->LW@y]

λ2=⟨1->RandomLieSeries[{1,2}], 2->RandomLieSeries[{1,2}]⟩

{lhs=λ2 // EulerE // adSeries[(((E^ad)-1)/ad), λ2] // RC[-λ2], rhs=Λ[λ2] // EulerE // adSeries[(((E^ad)-1)/ad), Λ[λ2], tb]; (lhs≡rhs)@{8}}

(atkv≡atkv1)@{9}

(atkv≡kv)@{8}

{A,B}={(Subscript[atkv, 1]),(Subscript[atkv, 2])}

((ℏ^(-1))(LS[LW@x+LW@y]-BCH[LW@y,LW@x]≡A-B-Ad[-LW@x][A]+Ad[LW@y][B]) && (Subscript[div, x])[A]+(Subscript[div, y])[B]≡(1/2)(Subscript[tr, LW@u])[adSeries[(ad/((E^ad)-1)), LW@x][LW@u]+adSeries[(ad/((E^ad)-1)), LW@y][LW@u]-adSeries[(ad/((E^ad)-1)), BCH[LW@x,LW@y]][LW@u]])@{9}

f=(V//Λ)[[1]]

f // RC[-f]

V[[1]] // RC[-V[[1]]]

f-(f // EulerE)

f// EulerE // (E^(-(Subscript[D, f])))

{A=LS[{x,y}, as], B=LS[{x,y}, bs], ϕ=CWS[{x}, ϕs]}

SeriesSolve[{A,B,ϕ},
(ℏ^(-1))(LS[LW@x+LW@y]-BCH[LW@y,LW@x]≡A-B-Ad[-LW@x][A]+Ad[LW@y][B])
&& ((Subscript[div, x])[A]+(Subscript[div, y])[B]≡ϕ + LieMorphism[LW@x->LW@y][ϕ] - LieMorphism[LW@x->BCH[LW@x,LW@y]][ϕ])
]

A[1]

B[1]

ϕ[1]

{A,B,ϕ}

ϕ@{11}