Solving linearized 5-gon in emergent 𝒫  and relation to KV

SetDirectory["C:/Users/kunoy/Dropbox/MyNotes/Research/Mathematica/WithDBN"];
(* SetDirectory["/Users/kunohome/Dropbox/MyNotes/Research/Mathematica/WithDBN"]; *)
<<FreeLie.m

Preparation from algebra

Computing basis of the kernel of a linear map

BasisKer[V1_,f_,V2_]:=Module[{$CA,$fV1,$l,$N},
$fV1=f@V1;
If[V1=={},{},
$l=Length[V1];
$CA=CoefficientArrays[$fV1,V2];
If[MatrixQ[Normal[$CA],#==0&],V1,
$N=NullSpace[
$CA[[2]]//Transpose
];
Table[
Expand@Sum[λ[[i]] V1[[i]],{i,$l}],
{λ,$N}
]
]
]
]

Basis of the free associative algebra and of the space of cyclic words

(Subscript[AssBasis, A_])[n_]:=AW@@@Tuples[A,n];
(Subscript[CycBasis, A_])[n_]:=Union[tr@(AW@@@Tuples[A,n])];

(Subscript[CycBasis, {x,y}])[4]

Powers in free associative algebras

AssPowers[1,u_]:=u;
AssPowers[n_,u_]:=u**AssPowers[n-1,u];

AssPowers[2,AW[x]-AW[y]]

The antipode

antipode[w_AW]:=antipode[w]=(-1)^Length[w] Reverse[w];
antipode[expr_]:=Expand[expr/.w_AW:>antipode[w]]

adjoint

itb[u_]:=u;
itb[u_,v__]:=itb[u,v]=b[u,itb[v]];
adjoint[n_,u_,v_]:=itb@@Join[Table[u,{i,n}],{v}];

Morphism in the free associative algebra

(Subscript[AssMorphism, rules_])[u_AW]:=(LieMorphism[rules]@u)@Length[u];
(Subscript[AssMorphism, rules_])[u_CW]:=(LieMorphism[rules]@u)@Length[u];
(Subscript[AssMorphism, rules_])[expr_]:=Expand[expr/.{w_AW:>(Subscript[AssMorphism, rules])[w],w_CW:>(Subscript[AssMorphism, rules])[w]}]

(Subscript[AssMorphism, {LW[x]:>LW[x]+ 2LW[y]}])[AW[x,x]+AW[x,y,z]]

FreeLie((Subscript[σ, 2k+1]))

wt[LW[(Subscript[σ, i_])]]:=i;
wt[a_LW]:=Sum[wt[LW@a[[i]]],{i,Length[List@@a]}];
L[n_]:=Module[{$m},
$m=Floor[n/3];
Select[Flatten[Table[
AllLyndonWords[i,Table[LW[(Subscript[σ, 2k+1])],{k,1,Floor[(n-1)/2]}]],
{i,1,$m}
],1],wt[#]==n&]
]

L[18]

The map R

The map R: FL --> FA (symmetric - horizontal)

(Subscript[R, A_])[0]=0;
(Subscript[R, A_])[u_LW]:=(Subscript[R, A])[u]=Which[
Deg[u]===1,0,
True,Module[{w1,w2},
{w1,w2}=LyndonFactorization[u];
Expand[b[ι[w1],(Subscript[R, A])[w2]]+b[(Subscript[R, A])[w1],ι[w2]]
+Sum[(1/2)*(τ[LW[α],w2]**AW[α]**antipode[τ[LW[α],w1]]-τ[LW[α],w1]**AW[α]**antipode[τ[LW[α],w2]]),
{α,A}]
]
]
];
(Subscript[R, A_])[expr_]:=Expand[expr/.LW[seq__]:>(Subscript[R, A])[LW[seq]]];

(Subscript[R, {x,y}])[LW[x,x,x,y]]

(Subscript[R, {x,y,z}])[b[b[LW[x],LW[y]],b[LW[x],LW[z]]]]

Do[
Print[" n = ",n," then "," R[(ad_x)^n y] = ",(Subscript[R, {x,y}])[adjoint[n,LW[x],LW[y]]]],{n,1,9}]

|R(y, x)x + R(x, y)y|

𝒮[f_AW]:=tr[(Subscript[AssMorphism, {LW[x]:>LW[y],LW[y]:>LW[x]}])[f]**AW[x]+f**AW[y]];
𝒮[expr_]:=Expand[expr/.f_AW:>𝒮[f]];

(Subscript[R, {x,y}])[LW[x,x,x,x,y]]
𝒮[(Subscript[R, {x,y}])[LW[x,x,x,x,y]]]

KV equations

Alekseev-Torossian’s ν (adopted to the current setting)

(Subscript[ν, deg_])[ψ_LW]:={(LieMorphism[{LW[x]:>LW[y],LW[y]:>LW[x]}]@ψ)@deg,ψ};
(Subscript[ν, deg_])[expr_]:=Expand[expr/.ψ_LW:> (Subscript[ν, deg])[ψ]];

(Subscript[ν, 4])[LW[x,y,x,y]+LW[x,x,y,y]]

Boundary condition (KV1) and its solutions

(* for tangential derivation u = (f,g) *)

CheckSpecial[{f_,g_}]:=b[LW[x],f]+b[LW[y],g]

CheckSpecial[{LW[y],0}]

SolKV1[n_]:=BasisKer[AllLyndonWords[n,{LW[x],LW[y]}],Map[RightComposition[(Subscript[ν, n]),CheckSpecial]],AllLyndonWords[n+1,{LW[x],LW[y]}]];

Timing[Table[Length@SolKV1[k],{k,1,11}]]

Divergence (KV2)

diver[{f_,g_}]:=tr[AW[x]**τ[LW[x],f]+AW[y]**τ[LW[y],g]]

diver[{LW[x,y],0}]

Coboundary operator (Subscript[δ, 2]):tr(x,y)-->tr(x,y,z)

(* for associative or cyclic words *)

(Subscript[δ, 2])[f_AW]:=Expand[(Subscript[AssMorphism, {LW[x]:> LW[y],LW[y]:>LW[z]}])[f]-(Subscript[AssMorphism, {LW[x]:> LW[x]+LW[y],LW[y]:>LW[z]}])[f]+(Subscript[AssMorphism, {LW[x]:> LW[x],LW[y]:>LW[y]+LW[z]}])[f]-f];
(Subscript[δ, 2])[f_CW]:=Expand[(Subscript[AssMorphism, {LW[x]:> LW[y],LW[y]:>LW[z]}])[f]-(Subscript[AssMorphism, {LW[x]:> LW[x]+LW[y],LW[y]:>LW[z]}])[f]+(Subscript[AssMorphism, {LW[x]:> LW[x],LW[y]:>LW[y]+LW[z]}])[f]-f];
(Subscript[δ, 2])[expr_]:=Expand[expr/.{f_AW:>(Subscript[δ, 2])[f],f_CW:>(Subscript[δ, 2])[f]}];

(Subscript[δ, 2])[AW[x,y,y]]

RxRyDuflo[k_]:=BasisKer[AllLyndonWords[k,{LW[x],LW[y]}],RightComposition[(Subscript[R, {x,y}]),𝒮,(Subscript[δ, 2])],(Subscript[CycBasis, {x,y,z}])[k]]

Table[Length@RxRyDuflo[k],{k,1,10}]

Duflo function

Duflo[n_]:=tr[AssPowers[n,AW[x]]+AssPowers[n,AW[y]]-AssPowers[n,AW[x]+AW[y]]]

Duflo[5]

(EM) GRT Equations

linearized pentagon eq. in emergent 𝒫

P3[ψ_LW]:=Module[{$d,$pd},
$d=Deg[ψ];
$pd=τ[LW[y],ψ];
Expand[
$pd+(LieMorphism[{LW[x]:>LW[y],LW[y]:>0}]@$pd)@($d-1)-(LieMorphism[{LW[x]:>LW[x]+LW[y],LW[y]:>0}]@$pd)@($d-1)-2(Subscript[R, {x,y}])[ψ]
]
];
P3[expr_]:=Expand[expr/.ψ_LW:>P3[ψ]];

Solutions to twist equations and three cycle equations

(* Rewriting ψ(x,y) --> ψ(-x-y,y) *)
(Subscript[Change, deg_])[ψ_]:=(LieMorphism[{LW[x]:> -LW[x]-LW[y],LW[y]:> LW[y]}]@ψ)@deg
(* ψ(x,y)+ψ(y,x)=0 *)
(Subscript[twist, deg_])[f_]:=f+(LieMorphism[{LW[x]:> LW[y],LW[y]:> LW[x]}]@f)@deg;
(* ψ(x,y)+ψ(y,-x-y)+ψ(-x-y,x)=0 *)
(Subscript[threecycle, deg_])[f_]:=f+(LieMorphism[{LW[x]:>LW[y],LW[y]:> -LW[x]-LW[y]}]@f)@deg+(LieMorphism[{LW[x]:> -LW[x]-LW[y],LW[y]:> LW[x]}]@f)@deg;

TwistSol[k_]:=BasisKer[AllLyndonWords[k,{LW[x],LW[y]}],(Subscript[twist, k]),AllLyndonWords[k,{LW[x],LW[y]}]];

ThreeSol[k_]:=BasisKer[AllLyndonWords[k,{LW[x],LW[y]}],(Subscript[threecycle, k]),AllLyndonWords[k,{LW[x],LW[y]}]];

ThreeTwistSol[k_]:=BasisKer[TwistSol[k],(Subscript[threecycle, k]),AllLyndonWords[k,{LW[x],LW[y]}]];

Table[Length@TwistSol[k],{k,1,10}]
Table[Length@ThreeSol[k],{k,1,10}]
Table[Length@ThreeTwistSol[k],{k,1,10}]

Experimental Computations

Solving linearized pentagon in emergent 𝒫

SolEMPent[k_]:=BasisKer[AllLyndonWords[k,{LW[x],LW[y]}],P3,(Subscript[AssBasis, {x,y}])[k-1]]

Do[Print[k, " and ",Timing[Length@SolEMPent[k]],L[k]],{k,1,16}]

Checking EM 5-gon implies |R(y,x)x + R(x,y)y| = Duflo

RightComposition[(Subscript[R, {x,y}]),𝒮]@SolEMPent[3]

Timing[RightComposition[(Subscript[R, {x,y}]),𝒮,(Subscript[δ, 2])]@SolEMPent[8]]

|R(y,x)x + R(x,y)y| is trivial for commutators in Lie((Subscript[σ, 2k+1]))?

Timing[diver[(Subscript[ν, 8])[Part[SolEMPent[8],1]]]]

Timing[RightComposition[(Subscript[R, {x,y}]),𝒮]@SolEMPent[8]]

Checking EM 5-gon implies KV1 and KV2

k=11;
Timing[Table[{CheckSpecial[(Subscript[ν, k])[ψ]],(Subscript[δ, 2])@diver[(Subscript[ν, k])[ψ]]},{ψ,SolEMPent[k]}]]

Checking KV1 + 2-cycle + 3-cycle implies |R(y,x)x + R(x,y)y| = Duflo (the answer is NO.)

k=7;
RightComposition[(Subscript[R, {x,y}]),𝒮,(Subscript[δ, 2])]@BasisKer[BasisKer[SolKV1[k],(Subscript[threecycle, k]),AllLyndonWords[k,{LW[x],LW[y]}]],RightComposition[(Subscript[Change, k]),(Subscript[twist, k])],AllLyndonWords[k,{LW[x],LW[y]}]]

k=7;
(Subscript[threecycle, k])@SolEMPent[k]