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

x=LW@"x"; y=LW@"y";
{α,β,γ} = LS /@ {x+b[x,y], y-b[x,b[x,y]], x+y-2b[x,y]}

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

bch=BCH[x,y]

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

{(Subscript[ω, 1]),(Subscript[ω, 2])} = CWS /@ {cw[x]-3cw[y,x,x],  cw[y]+cw[y,y]}

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

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

λ1=λ; λ2=⟨x->β, y -> γ⟩; 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])[λ]])))}

Unclassified aside: an alternative formulation of Λ (on March 1, 2015, this took 61 Seconds to degree 8):

λ3=⟨x->RandomLieSeries[{x,y}], y->RandomLieSeries[{x,y}]⟩;
{lhs=λ3 // EulerE // adSeries[(((E^ad)-1)/ad), λ3] // RC[-λ3], rhs=Λ[λ3] // EulerE // adSeries[(((E^ad)-1)/ad), Λ[λ3], tb]; (lhs≡rhs)@{7}} // Timing

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

u=LW@"u"; v=LW@"v";
With[{γ=b[b[v,u],u]}, (Subscript[tr, u])[γ]]

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

(Subscript[J, x])[γ]

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

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

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

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

x=LW@"x"; y=LW@"y";
{(Subscript[ζ, a])=El[⟨x->LS[x+b[x,y]], y->LS[y-b[x,b[x,y]]]⟩, CWS[cw[x]-3cw[x,y,x]]],
(Subscript[ζ, b])=El[⟨x->LS[y-b[x,y]], y->LS[x+y+b[y,b[x,y]]]⟩, CWS[cw[y]-2cw[x,y]]],
(Subscript[ζ, c])=El[⟨x->LS[x-b[b[x,y],b[x,y]]], y->LS[y+3b[x,b[x,y]]]⟩, CWS[cw[x]-2cw[x,y]+cw[x,y,x]]]}

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

{(Subscript[ζ, a]) // ((dη)^x), (Subscript[ζ, a]) // ((dη)^y)}

{(Subscript[ζ, d])=El[λ, 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Δ[y,y,z]}

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

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

(Subscript[ξ, a])=Es[⟨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[u,v,u]]]

(Subscript[ξ, b])=RandomEsSeries[0, {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

Rl[a_,b_]:= El[⟨a->LS[0], b->LS[LW@a]⟩, CWS[0]];
iRl[a_,b_]:= El[⟨a->LS[0], b->-LS[LW@a]⟩, CWS[0]];
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]];

lhs=Rl[1,2]**Rl[1,3]**Rl[2,3]; rhs=Rl[2,3]**Rl[1,3]**Rl[1,2];
{lhs@{3}, (lhs≡rhs)@{5}}

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

t1=iRs[12,1]iRs[2,7]iRs[8,3]iRs[4,11]Rs[16,5]Rs[6,13]Rs[14,9]Rs[10,15];
Do[t1 = t1 // dm[1,k,1], {k,2,16}];t1@{6}

t2= iRs[r,6]Rs[2,4]iRs[g,9]Rs[5,7]iRs[b,3]Rs[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.

x=LW["x"]; y=LW["y"]; z=LW["z"];
α=LS[{x,y}, αs]; β=LS[{x,y}, βs];γ=CWS[{x,y}, γs];
(Subscript[V, 0])=Es[⟨x->α, y->β⟩, γ];

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

R4Eqn=(Subscript[V, 0])**(Rs[x,z] // dΔ[x,x,y]) ≡ Rs[y,z]**Rs[x,z]**(Subscript[V, 0]) ;UnitarityEqn=(Subscript[V, 0])**((Subscript[V, 0])//dA) ≡ Es[⟨x->LS[0], y->LS[0]⟩,CWS[0]];
CapEqn=((Subscript[V, 0])**(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];
{(Subscript[V, 0])@{4}, κ@{6}}

Series[(1/4)Log[((ℏ/2)/(Sinh[ℏ/2]))], {ℏ,0,12}]

Λ[(Subscript[V, 0])]

logF = Λ[(Subscript[V, 0])][[1]]  // dσ[{x,y}->{y,x}]

atkv=logF // EulerE // adSeries[(((E^ad)-1)/ad), logF, tb];
{f=(Subscript[atkv, x]), g=(Subscript[atkv, y])}

On March 1, 2015, the following took 379 seconds in degree 8:

((ℏ^(-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]])@{6} // Timing

{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}

Section 3.3 - The involution τ and the twist equation

Θl[x_,y_, s_] := El[⟨x->LS[s LW@y], y->LS[s LW@x]⟩, CWS[0]];
Θs[x_,y_,s_] := Θl[x,y,s] // Γ;
{Θl[x,y,1], Θs[x,y,1]}

τV=Rs[x,y]**((Subscript[V, 0])//dσ[{x,y}->{y,x}])**Θs[x,y,-1/2];
((Subscript[V, 0])≡τV)@{6}

{A=LS[{x,y}, As], B=LS[{x,y}, Bs]};
msgs=SeriesSolve[{A,B},
(ℏ^(-1))(b[x, A]+b[y,B] ≡ LS[0])∧((Subscript[div, x])[A]+(Subscript[div, y])[B]≡CWS[0])];
{A,B}

Read[msgs]

A@12; Length[Last[#]]& /@ Read[msgs]

{A1=LS[{x,y}, A1s], B1=LS[{x,y}, B1s]};
msgs1=SeriesSolve[{A1,B1},
(ℏ^(-1))(b[x, A1]+b[y,B1] ≡ LS[0])∧((Subscript[div, x])[A1]+(Subscript[div, y])[B1]≡CWS[0])∧(A1 ≡ (B1 // LieMorphism[x->y, y->x]))];
A1@12; Length[Last[#]]& /@ Read[msgs1]

Section 3.4 - Drinfel’d Associators

{b[t[1,3],t[4,2]], b[t[1,2]+t[1,3],t[2,3]]}

b[t[1,3], t[1,2]]

b[t[1,3], t[1,2]] // DKS

{((t[2,3])^(σ[{2,4},{1,5},{3,7,8},{9}]))// DKS, ((t[2,3])^(σ[24,15,378,9]))// DKS}

R=DKS[t[1,2]/2];
{R**(R^(σ[2,3])),R**(R^(σ[12,3]))}

Φs[2,1]=Φs[3,1]=Φs[3,2]=0;Φs[3,1,2]=1/24; (Subscript[Φ, 0])=DKS[3, Φs];
SeriesSolve[(Subscript[Φ, 0]), (((Subscript[Φ, 0])^(σ[3,2,1]))≡-(Subscript[Φ, 0]))∧((Subscript[Φ, 0])**((Subscript[Φ, 0])^(σ[1,23,4]))**((Subscript[Φ, 0])^(σ[2,3,4]))≡((Subscript[Φ, 0])^(σ[12,3,4]))**((Subscript[Φ, 0])^(σ[1,2,34])))];
(Subscript[Φ, 0])@{6}

R=DKS[t[1,2]/2];
((R^(σ[12,3])) ≡ (Subscript[Φ, 0])**(R^(σ[2,3]))**(((-(Subscript[Φ, 0])))^(σ[1,3,2]))**(R^(σ[1,3]))**((Subscript[Φ, 0])^(σ[3,1,2]))∧(((-R))^(σ[12,3])) ≡ (Subscript[Φ, 0])**(((-R))^(σ[2,3]))**(((-(Subscript[Φ, 0])))^(σ[1,3,2]))**(((-R))^(σ[1,3]))**((Subscript[Φ, 0])^(σ[3,1,2])))@{6}

Section 3.5 - Associators in (𝒜^w)

(Subscript[V, 12])=(Subscript[V, 0])//dσ[{x,y}->{1,2}];
(Subscript[Φ, V]) = ((((Subscript[V, 12])//dA))^(σ[12,3]))**((((Subscript[V, 12])//dA))^(σ[1,2]))**((Subscript[V, 12])^(σ[2,3]))**((Subscript[V, 12])^(σ[1,23]))

(Subscript[Φ, V])**((Subscript[Φ, V])^(σ[1,23,4]))**((Subscript[Φ, V])^(σ[2,3,4]))≡((Subscript[Φ, V])^(σ[12,3,4]))**((Subscript[Φ, V])^(σ[1,2,34]))

ϕ = ((Subscript[Φ, V]) // Λ)[[1]];
(b[LW@1,(Subscript[ϕ, 1])]+b[LW@2,(Subscript[ϕ, 2])]+b[LW@3,(Subscript[ϕ, 3])])@{6}

DK2Es[s___][ζ_] := El[ζ // αMap[s], CWS[0]] // Γ;
DK2Es[1,2,3][(Subscript[Φ, 0])]

The computation below takes a a couple of hours and yields “BS[8 True,False,...]”:

TrueQ[DK2Es[1,2,3][(Subscript[Φ, 0])]≡(Subscript[Φ, V])]@{8}

Section 3.6 -  Solving the Kashiwara-Vergne Equations Using a Drinfel’d Associator

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

(Subscript[Z, B]) // DK2Es[1,2,3,4]// ((tη)^1) // ((tη)^3)

The computation below takes a few hours and yields “BS[8 True,False,...]”:

(Subscript[V, B]) = (Subscript[Z, B]) // DK2Es[1,2,3,4] // ((tη)^1) // ((tη)^3) // ((hη)^2) // ((hη)^4) // hσ[{1,3}->{x,y}] // tσ[{2,4}->{x,y}];TrueQ[(Subscript[V, B])[[1]]≡(Subscript[V, 0])[[1]]]@{8}

νinv=(Subscript[Φ, 0]) //DK2Es[1,2,3] // dS[2] // dm[3,2,2] // dm[2,1,x]

(νinv**Cap**Cap**Cap**Cap)@{6}

(Subscript[Φ, 1])=(Subscript[((Subscript[Φ, 0])), 3]) // LieMorphism[LW@1->-x-y,LW@2->y]

F=⟨x->LieMorphism[y->-x-y][-(Subscript[Φ, 1])],
y->LS[(x+y)/2]~BCH~LieMorphism[x->y, y->-x-y][-(Subscript[Φ, 1])]~BCH~LS[-y/2]⟩

(F≡(Subscript[V, 0])[[1]])@{7}

Section 3.7 - A Potential (Subscript[S, 4]) Action on Solutions of KV

(Subscript[ρ, 2])[V_] := V // (((-1))^deg);
(Subscript[V, 1])=Es[⟨x->LS[0], y->LS[-x/2]⟩, CWS[0]]**(Subscript[V, 0]);
{((Subscript[V, 1])≡(Subscript[ρ, 2])[(Subscript[V, 1])])@{8}, ((Subscript[V, 0])≡Rs[x,y]**(Subscript[ρ, 2])[(Subscript[V, 0])])@{8}}

(Subscript[ρ, 3])[ζ_Es] := ζ // dS[y] // dΔ[y,y,z] // dm[x,z,x] // dσ[{x,y}->{y,x}];
(Subscript[ξ, c])=RandomEsSeries[1, {x,y}];
(Subscript[ξ, c])≡((Subscript[ξ, c])//(Subscript[ρ, 3])//(Subscript[ρ, 3])//(Subscript[ρ, 3]))

(Subscript[V, 2])=(Subscript[V, 0])**Θs[x,y,-1/4]**Es[⟨x->LS@0, y->LS@0⟩, CWS[cw[x]/12-cw[y]/12]-(2Cap[[2]]//tΔ[x,x,y])];
((Subscript[V, 2])≡(Subscript[ρ, 3])[(Subscript[V, 2])])@{6}