SetDirectory["C:\\drorbn\\AcademicPensieve\\People\\Kuno"];
<< FreeLie.m

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

Goal: Implement the “Emergent Drinfel’d-Kohno Algebra”  EDK following

EDK[k_Integer, x_FL]: an element in the image of (Subscript[L, k]).
EDK[j_Integer,k_Integer, w_AW]: an element in the image of (Subscript[A, jk]).

EDKBasis[ps, s, d] produces the basis of the EDK algebra with poles ps, strands 1,...,s, and at degree d.

EDKBasis[ps_List, s_Integer, d_Integer]:= Flatten@{
Table[EDK[j,k,#]&/@AllWords[d-1,ps],{j,1,s-1},{k,j+1,s}],
Table[EDK[k,#]&/@AllLyndonWords[d,ps],{k,s}]
}

EDKBasis[{x,y},3,3]

EDK[j_,k_,w_AW]/;j>k:=EDK[k,j,Antipode[w]];

EDK[__,0]=0;
EDK /: EDK[jk__, x1_] + EDK[jk__, x2_] := EDK[jk, x1+x2];
EDK /: c_*EDK[jk__, x_] := EDK[jk, Expand[c x]];
EDK /: b[EDK[jk1__, c_*(x1_LW|x1_AW)], EDK[jk2__, x2_]] := Expand[c b[EDK[jk1, x1], EDK[jk2,x2]]];
EDK /: b[EDK[jk1__, x1_], EDK[jk2__, c_*(x2_LW|x2_AW)]] := Expand[c b[EDK[jk1, x1], EDK[jk2,x2]]];
EDK /: b[EDK[jk1__, x1_], EDK[jk2__,x2_Plus]]:= b[EDK[jk1, x1],EDK[jk2,#]]&/@x2;
EDK /: b[EDK[jk1__,x1_Plus], EDK[jk2__,x2_]] := b[EDK[jk1,#],EDK[jk2,x2]]&/@x1;

EDK /: b[EDK[_,_,_],EDK[_,_,_]]:=0

EDK/: b[EDK[k1_,w1_LW],EDK[j2_,k2_,w2_AW]] := Which[
k1==j2, -EDK[j2,k2,w2**ι[w1]],
k1==k2, EDK[j2,k2,ι[w1]**w2],
True,0
];
EDK/: b[EDK[j2_,k2_,w2_AW], EDK[k1_,w1_LW]]:=Expand[-b[EDK[k1,w1],EDK[j2,k2,w2]]]

b[EDK[1,LW[x,y]], EDK[1,2,AW[z,z,x,y]]]

Cases[{AW[1],LW[2],Yu[3]}, x_LW|x_AW]

AllLyndonWords[4,{x,y,z}]/. w_LW:> Union[List@@w]

EDK/: b[EDK[k1_,w1_LW],EDK[k2_,w2_LW]] := Which[
k1==k2,EDK[k1,b[w1,w2]],
k1<k2,EDK[k1,k2,Sum[τ[LW@p,w2]**AW[p]**Antipode[τ[LW@p,w1]],{p,Union[List@@w1]⋂Union[List@@w2]}]],
k2<k1,EDK[k2,k1,Sum[-τ[LW@p,w1]**AW[p]**Antipode[τ[LW@p,w2]],{p,Union[List@@w1]⋂Union[List@@w2]}]]
]

Testing anti-symmetry and Jacobi for EDK:

bas=EDKBasis[{x,y,z},3,4]
Union@Table[{α,β}=αβ; b[α,β]+b[β,α],{αβ,Subsets[bas,{2}]}]

bas=EDKBasis[{x,y,z},3,4]
Union@Table[{α,β,γ}=αβγ;
b[α,b[β,γ]]+b[β,b[γ,α]]+b[γ,b[α,β]],{αβγ,Subsets[bas,{3}]}
]

σ

(Φ^(σ[1,23,4]))->(Φ^(σ[{1},{2,3},{4}]))->σ[{1},{2,3},{4}][Φ]
(Φ^(σ[2,3,1]))
(Φ^(σ[1,x23,4]))
Δ[i->jk]
EDK[j1,sum of Lie words]+EDK[j2,sum of Lie words]+EDK[j,k,sum of Associative words]+
p2s

σ /: ((ℰ_)^(s_σ)) := s[ℰ];
σ[lft___, i_Integer, rgt___] := σ[lft, IntegerDigits[i], rgt];
σ[___][0]=0;
x_Plus // s_σ := s[#]& /@ x;
EDK[jk__, x_Plus] //s_σ:= s[EDK[jk, #]]& /@ x;
EDK[jk__, c_*(w_LW|w_AW)] // s_σ := Expand[c*s[EDK[jk,w]]];
EDK[k_, LW[x_]] // s_σ := Sum[EDK[α,LW[x]], {α, s[[k]]}];
EDK[k_, w_LW] // s_σ := b@@(s[EDK[k,#]]& /@ LyndonFactorization[w]);
EDK[j_,k_,AW[]] // s_σ := Sum[EDK[α,β,AW[]],{α,s[[j]]},{β,s[[k]]}];
EDK[j_,k_,AW[x_,w___]] // s_σ := b[s@EDK[k,LW@x],s@EDK[j,k,AW[w]]]

bas=EDKBasis[{x,y},1,1];
Column@Table[α->(α^(σ[12])),{α,bas}]

bas=EDKBasis[{x,y},2,1];
Column@Table[α->(α^(σ[12,3])),{α,bas}]

bas=EDKBasis[{x,y},2,2];
Column@Table[α->(α^(σ[12,3])),{α,bas}]

bas=EDKBasis[{x,y},2,3];
Column@Table[α->(α^(σ[12,3])),{α,bas}]

bas=EDKBasis[{x,y},2,4];
Column@Table[α->(α^(σ[12,3])),{α,bas}]

bas=EDKBasis[{x,y},2,4];
Column@Table[α->(α^(σ[1,23])),{α,bas}]

bas=EDKBasis[{x,y},2,2];
Column@Table[α->(α^(σ[3,12])),{α,bas}]

bas=EDKBasis[{x,y},2,3];
Column@Table[α->(α^(σ[3,12])),{α,bas}]

bas1=EDKBasis[{x,y},2,4];
bas2=EDKBasis[{x,y},2,4];
s=σ[12,3];
Column@DeleteCases[_->0][Flatten@Table[{α,β}->((b[α,β])^s)-b[(α^s),(β^s)],{α,bas1},{β,bas2}]]

bas1=EDKBasis[{x,y},2,4];
bas2=EDKBasis[{x,y},2,4];
s=σ[1,23];
Column@DeleteCases[_->0][Flatten@Table[{α,β}->((b[α,β])^s)-b[(α^s),(β^s)],{α,bas1},{β,bas2}]]

bas1=EDKBasis[{x,y},2,4];
bas2=EDKBasis[{x,y},2,4];
s=σ[23,1];
Column@DeleteCases[_->0][Flatten@Table[{α,β}->((b[α,β])^s)-b[(α^s),(β^s)],{α,bas1},{β,bas2}]]

The Full Pole-Strand “Operad”.

Goal: Implement the pentagon,
Φ**(Φ^(σ[y->y+1,,2]))**(Φ^(σ[x->y,y->1,,2]))==(Φ^(σ[x->x+y,y->1,,2]))**(Φ^(σ[12])).
A more modest goal: Implement (Subscript[psΔ, s])[y], which shifts all the strands (1..s) one unit to the right and creates and new strand 1 by doubling pole y.
The pentagon will now be:
Φ**psΔ[y][Φ]**...

psΔ[_][0]=0;
x_Plus // psΔ[y_] := psΔ[y]/@ x;
EDK[k_,x_]//psΔ[y_] := EDK[k+1,x]+EDK[1,k+1,τ[LW@y,x]];
EDK[j_,k_,x_]//psΔ[_]  := EDK[j+1,k+1,x];

bas=EDKBasis[{x,y},2,3];
Table[α->psΔ[y][α],{α,bas}]//Column

bas1=EDKBasis[{x,y},2,3];
bas2=EDKBasis[{x,y},2,4];
Column@DeleteCases[_->0][Flatten@Table[{α,β}->psΔ[y][b[α,β]]-b[psΔ[y][α],psΔ[y][β]],{α,bas1},{β,bas2}]]

LM[___][0]=0;
x_Plus // lm_LM := lm/@ x;
lm_LM[c_ w_LW]:=Expand[c lm[w]];
lm_LM[c_ w_AW]:=Expand[c lm[w]];
lm_LM[EDK[jk__,x_]]:=EDK[jk,Expand[lm[x]]];
LM[rules___][LW[w_]]:=Distribute[LW[w]/.{rules}]/.LW[0]->0;
LM[rules___][w_LW] := (LM[rules][w] = b @@ (LM[rules] /@ LyndonFactorization[w]));
LM[rules___][AW[]] =AW[];
LM[rules___][AW[w_]] := Distribute[AW[w]/.{rules}]/.AW[0]->0;
LM[rules___][w_AW] := LM[rules][w] = Module[{w1,w2},
w1=Take[w, Floor[Length[w]/2]];
w2=Drop[w, Floor[Length[w]/2]];
LM[rules][w1]**LM[rules][w2]
];

LM[x->0][LW[x,y]]

LM[x->x+y,y->z][LW[x]]

LM[x->x+y,y->z][LW[y]]

LM[x->x+y,y->z][LW[x,y]]

LM[x->x+y,y->z][AW[x,x,y,x]]

AW[x,y,x]//LM[x->x+y,y->z]//LM[z->z1+z2]

Φ**(Φ^(σ[y->y+1,,2]))**(Φ^(σ[x->y,y->1,,2]))==(Φ^(σ[x->x+y,y->1,,2]))**(Φ^(σ[12])).

bas=EDKBasis[{x,y},1,4]

Table[α->Column@{α,α//psΔ[y],α//psΔ[y]//LM[x->y,y->0],α//psΔ[y]//LM[x->x+y,y->0],(α^(σ[12]))},{α,bas}]//Column

Pentagon[α_]:=α+(α//psΔ[y])+(α//psΔ[y]//LM[x->y,y->0])-(α//psΔ[y]//LM[x->x+y,y->0])-(α^(σ[12]))

Pentagon/@EDKBasis[{x,y},1,5]

EDKBasis[{x,y},2,5]

AllWords[4,{x,y}]

mat[d_]:=Module[{p},Table[
p=Pentagon[α][[3]];
Table[Coefficient[p,β],{β,AllWords[d-1,{x,y}]}],
{α,EDKBasis[{x,y},1,d]}
]]

mat[5]//MatrixForm

NullSpace[mat[5]\[Transpose]]

Table[Echo[d->Timing@Length@NullSpace[mat[d]\[Transpose]]], {d,3,20}]