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[2,1,1],  CW[2]+CW[2,2]}

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])[λ]])))}

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

λ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}} // Timing

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

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

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 El of (Subscript[(A^w), exp])

(Subscript[x, 1])=LW[1]; (Subscript[x, 2])=LW[2];
{(Subscript[ζ, a])=El[⟨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[1,2,1]]],
(Subscript[ζ, b])=El[⟨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[1,2]]],
(Subscript[ζ, c])=El[⟨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[1,2]+CW[1,2,1]]]}

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])=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Δ[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 Ef of (Subscript[(A^w), exp]) and its stronger precursor Es

u=LW@"u"; v=LW@"v";
(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"]]]

SeedRandom[0]; (Subscript[ξ, b])=Es[⟨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

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.

α=LS[{x,y}, αs]; β=LS[{x,y}, βs];γ=CWS[{x,y}, γs];
V=Es[⟨x->α, y->β⟩, γ];

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

R4Eqn=V**(Rs[x,z] // dΔ[x,x,y]) ≡ Rs[y,z]**Rs[x,z]**V ;UnitarityEqn=(V**(V//dA[x]//dA[y]) ≡ 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]= 0; αs[y]=-1/2;
SeriesSolve[{α, β,γ, κ}, ((ℏ^(-1))R4Eqn) && UnitarityEqn && CapEqn];
{V, κ}

Λ[V]

From the AT paper:

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

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

logF1=V[[1]] // dσ[{x,y}->{y,x}];
atkv1=logF1 // EulerE // adSeries[(((E^ad)-1)/ad), logF1] // RC[-logF1]

On March 1, 2015, the following took 74 Seconds:

(atkv≡atkv1)@{8} // Timing

LS[LW@x+LW@y]-BCH[LW@y,LW@x]≡A-B-Ad[-LW@x][A]+Ad[LW@y][B]

ϕ=CWS[{x}, ϕs];
SeriesSolve[ϕ,
((Subscript[div, x])[f]+(Subscript[div, y])[g]≡ϕ + LieMorphism[LW@x->LW@y][ϕ] - LieMorphism[LW@x->BCH[LW@x,LW@y]][ϕ])
];
ϕ@{8}

{A1=LS[{x,y}, as], B1=LS[{x,y}, bs], ϕ1=CWS[{x}, ϕ1s]};
SeriesSolve[{A1,B1,ϕ1},
(ℏ^(-1))(LS[LW@x+LW@y]-BCH[LW@y,LW@x]≡A1-B1-Ad[-LW@x][A1]+Ad[LW@y][B1])
&& ((Subscript[div, x])[A1]+(Subscript[div, y])[B1]≡ϕ1 + LieMorphism[LW@x->LW@y][ϕ1] - LieMorphism[LW@x->BCH[LW@x,LW@y]][ϕ1])
];
{A1,B1,ϕ1}

On March 1, 2015, the following took 64 Seconds:

ϕ1@{11} // Timing

On March 1, 2015, the following took 379 seconds:

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

{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, 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]]]

TrueQ[atkv≡⟨x->F,y->G⟩]@{8}

On March 1, 2015, a complete run of this notebook took 712 seconds.

TimeUsed[]