Solving linearized 5-gon in emergent 𝒫

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[{$l,$N},
$l=Length[V1];
$N=NullSpace[
Table[
Coefficient[f[V1[[i]]],V2],
{i,$l}
]//Transpose
];
Table[
Expand@Sum[λ[[i]] V1[[i]],{i,$l}],
{λ,$N}
]
]

Partial derivation (borrowed from DBN’s “FreeLie”)

(* not contained in the package? *)

τ[y_LW, w_LW] /; Deg[y]==1 := τ[y,w] = Which[
y===w, AW[],
Deg[w]===1, 0,
True, Module[{w1,w2},
{w1,w2}=LyndonFactorization[w];
ι[w1]**τ[y,w2]-ι[w2]**τ[y,w1]
]
];
τ[y_, ls_LieSeries] := τ[y, ls] = New[ASeries[as],
as[d_] := as[d] = τ[LW[y], ls[d+1]]
];
τ[y_, expr_] := Expand[expr /. w_LW :> τ[LW[y], w]];

Basis of the free associative algebra

AssBasis[n_]:=AW@@@Tuples[{x,y},n]

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]:=(-1)^Length[w] Reverse[w];
antipode[expr_]:=Expand[expr/.w_AW:>antipode[w]]

Morphism in the free associative algebra

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

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

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

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

𝒮[expr_]:=tr[(Subscript[AssMorphism, {LW[x]:>LW[x],LW[y]:>-LW[x]-LW[y]}])[expr]**AW[y]+(Subscript[AssMorphism, {LW[x]:>LW[y],LW[y]:>-LW[x]-LW[y]}])[expr]**AW[x]]

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

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

Rxyyx[expr_]:=Expand[(Subscript[R, {x,y}])[expr]+(Subscript[AssMorphism, {LW[x]:>LW[y],LW[y]:>LW[x]}])[(Subscript[R, {x,y}])[expr]]];

Rxyyx[LW[x,z,x,y]]

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

(* ψ(x,y)+ψ(y,x)=0 *)

TwistSol[n_]:=Module[{$al,$altw,$Ntest},
$al=AllLyndonWords[n,{LW[x],LW[y]}];
$altw=$al+Table[
(LieMorphism[{LW[x]:>LW[y],LW[y]:>LW[x]}]@$al[[i]])@n,{i,Length[$al]}];
$Ntest=NullSpace[
Table[
Coefficient[$altw[[i]],$al],{i,Length[$al]}
]//Transpose
];
Table[
Expand@Sum[λ[[i]] $al[[i]],{i,Length[$al]}],
{λ,$Ntest}]
]

Solutions to KV1

ATν[ψ_]:=b[LW[x],LieMorphism[{LW[x]:>-LW[x]-LW[y],LW[y]:>LW[x]}]@ψ]+b[LW[y],LieMorphism[{LW[x]:>-LW[x]-LW[y],LW[y]:>LW[y]}]@ψ];

Table[ATν[ψ]@5,{ψ,AllLyndonWords[4,{LW[x],LW[y]}]}]

SolKV1[n_]:=Module[{$alln,$allnplus,$imν,$Ntest},
$alln=AllLyndonWords[n,{LW[x],LW[y]}];
$allnplus=AllLyndonWords[n+1,{LW[x],LW[y]}];
$imν=Table[ATν[$alln[[i]]]@(n+1),{i,Length[$alln]}];
$Ntest=NullSpace[
Table[
Coefficient[$imν[[i]],$allnplus],{i,Length[$alln]}
]//Transpose
];
Table[
Expand@Sum[λ[[i]] $alln[[i]],{i,Length[$alln]}],
{λ,$Ntest}] 
]

TwistSol[4]

Twist and KV1

TwistKV1Sol[n_]:=Module[{$alln,$allnplus,$alltwkv1,$Ntest},
$alln=AllLyndonWords[n,{LW[x],LW[y]}];
$allnplus=AllLyndonWords[n+1,{LW[x],LW[y]}];
$alltwkv1=$alln+Table[
(LieMorphism[{LW[x]:>LW[y],LW[y]:>LW[x]}]@$alln[[i]])@n,{i,Length[$alln]}]+Table[ATν[$alln[[i]]]@(n+1),{i,Length[$alln]}];
$Ntest=NullSpace[
Table[
Coefficient[$alltwkv1[[i]],Join[$alln,$allnplus]],{i,Length[$alln]}
]//Transpose
];
Table[
Expand@Sum[λ[[i]] $alln[[i]],{i,Length[$alln]}],
{λ,$Ntest}]
]

TwistSol[6]
TwistKV1Sol[6]

Table[Length@TwistKV1Sol[k],{k,1,11}]

Duflo function

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

Duflo[5]

Timing[TwistSol[5]]

Computations

Checking if twist eq implies |R(x, -x-y)y + R(y, -x-y)x| = Duflo.

k=2;
test=TwistSol[k];
l=Length[test];
Do[
Print[
Part[test,i]," and ",
𝒮[(Subscript[R, {x,y}])@Part[test,i]]
],
{i,l}
]

k=5;
test=TwistSol[k];
l=Length[test];
Do[
Print[
Part[test,i]," and ",
𝒮[(Subscript[R, {x,y}])@Part[test,i]]
],
{i,l}
]

Duflo[5]

k=6;
test=TwistSol[k];
l=Length[test];
Do[
Print[
Part[test,i]," and ",
𝒮[(Subscript[R, {x,y}])@Part[test,i]]
],
{i,l}
]

Checking if twist eq. + KV1 implies |R(x, -x-y)y + R(y, -x-y)x| = Duflo.

(* The result is negative. *)

k=5;
test=TwistKV1Sol[k];
l=Length[test];
Do[
Print[
Part[test,i]," and ",
𝒮[(Subscript[R, {x,y}])@Part[test,i]]
],
{i,l}
]

Solving linearized pentagon in emergent 𝒫

Do[
Print[k, " and ",
Timing[Length@BasisKer[AllLyndonWords[k,{LW[x],LW[y]}],P3,AssBasis[k-1]]]],
{k,1,14}]

k=3;
test=BasisKer[AllLyndonWords[k,{LW[x],LW[y]}],P3,AssBasis[k-1]]
Duflo[k]
Table[𝒮[(Subscript[R, {x,y}])[test[[i]]]],{i,Length[test]}]

k=5;
test=BasisKer[AllLyndonWords[k,{LW[x],LW[y]}],P3,AssBasis[k-1]]
Duflo[k]
Table[𝒮[(Subscript[R, {x,y}])[test[[i]]]],{i,Length[test]}]