Pensieve Header: Solving for a PPS associator degree by degree.

Initialization

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

Φ[2]=(Subscript[𝕆, HR,{x,y},{1}])[(Subscript[𝒜, 0])[(Subscript[AW, 1])[]+(1/24) (Subscript[AW, 1])[x,y]-(1/24) (Subscript[AW, 1])[y,x]]]

(Subscript[Pentagon, d_])[Φ_]:=(Subscript[IM, d])[Φ//(Subscript[sη, 2]), Φ//(Subscript[sσ, 1->2])//(Subscript[pΔ, y->y,z])//(Subscript[p2s, z->1]),Φ//(Subscript[sσ, 1->2])//(Subscript[p2s, y->1])//(Subscript[pσ, x->y])//(Subscript[pη, x])]-(Subscript[IM, d])[Φ//(Subscript[sσ, 1->2])//(Subscript[p2s, y->1])//(Subscript[pΔ, x->x,y]),Φ//(Subscript[sΔ, 1->1,2])]

Solving to Degree 3

Select[(Subscript[Basis, 3])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]

d=3; i=0;
Φ[d]=Φ[d-1]+Sum[(Subscript[c, d,++i])B,{B,Select[(Subscript[Basis, d])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]}]

rels=Union@@(List@@(Subscript[Pentagon, d])[Φ[d]][[1]]/.{
(Subscript[𝒜, 0])[A_]:>Table[Coefficient[A,B],{B,(Subscript[Basis, d,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}],
(Subscript[𝒜, c[1,2]])[A_]:>Table[Coefficient[A,B],{B,(Subscript[AW, (OverBar[1])])[](Subscript[AW, (OverBar[2])])[](Subscript[Basis, d-1,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}]
})

eqns=#==0&/@rels

vars=Union[Cases[eqns,(Subscript[c, d,_]),∞]]

sol=Solve[eqns,vars][[1]]

sol/.Rule->Set

Φ[3]

(Subscript[c, 3,2])=0

Φ[3]

Solving to Degree 4

d=4; i=0;
Φ[d]=Φ[d-1]+Sum[(Subscript[c, d,++i])B,{B,Select[(Subscript[Basis, d])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]}]

rels=Union@@(List@@(Subscript[Pentagon, d])[Φ[d]][[1]]/.{
(Subscript[𝒜, 0])[A_]:>Table[Coefficient[A,B],{B,(Subscript[Basis, d,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}],
(Subscript[𝒜, c[1,2]])[A_]:>Table[Coefficient[A,B],{B,(Subscript[AW, (OverBar[1])])[](Subscript[AW, (OverBar[2])])[](Subscript[Basis, d-1,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}]
})

eqns=#==0&/@rels

vars=Union[Cases[eqns,(Subscript[c, d,_]),∞]]

sol=Solve[eqns,vars][[1]]

sol/.Rule->Set

Φ[d]

Solving to Degree 5

d=5; i=0;
Φ[d]=Φ[d-1]+Sum[(Subscript[c, d,++i])B,{B,Select[(Subscript[Basis, d])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]}]

Short[
rels=Union@@(List@@(Subscript[Pentagon, d])[Φ[d]][[1]]/.{
(Subscript[𝒜, 0])[A_]:>Table[Coefficient[A,B],{B,(Subscript[Basis, d,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}],
(Subscript[𝒜, c[1,2]])[A_]:>Table[Coefficient[A,B],{B,(Subscript[AW, (OverBar[1])])[](Subscript[AW, (OverBar[2])])[](Subscript[Basis, d-1,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}]
}),
10]

eqns=#==0&/@rels;

vars=Union[Cases[eqns,(Subscript[c, d,_]),∞]]

sol=Solve[eqns,vars][[1]]

sol/.Rule->Set

(Subscript[c, 5,5])=0

Φ[d]

Solving to Degree 6

d=6; i=0;
Φ[d]=Φ[d-1]+Sum[(Subscript[c, d,++i])B,{B,Select[(Subscript[Basis, d])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]}]

Short[
rels=Union@@(List@@(Subscript[Pentagon, d])[Φ[d]][[1]]/.{
(Subscript[𝒜, 0])[A_]:>Table[Coefficient[A,B],{B,(Subscript[Basis, d,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}],
(Subscript[𝒜, c[1,2]])[A_]:>Table[Coefficient[A,B],{B,(Subscript[AW, (OverBar[1])])[](Subscript[AW, (OverBar[2])])[](Subscript[Basis, d-1,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}]
}),
10]

eqns=#==0&/@rels;

vars=Union[Cases[eqns,(Subscript[c, d,_]),∞]]

sol=Solve[eqns,vars][[1]]

sol/.Rule->Set

Φ[d]

PrintProfile[]

Solving to Degree 7

d=7; i=0;
Φ[d]=Φ[d-1]+Sum[(Subscript[c, d,++i])B,{B,Select[(Subscript[Basis, d])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]}]

Short[
rels=Union@@(List@@(Subscript[Pentagon, d])[Φ[d]][[1]]/.{
(Subscript[𝒜, 0])[A_]:>Table[Coefficient[A,B],{B,(Subscript[Basis, d,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}],
(Subscript[𝒜, c[1,2]])[A_]:>Table[Coefficient[A,B],{B,(Subscript[AW, (OverBar[1])])[](Subscript[AW, (OverBar[2])])[](Subscript[Basis, d-1,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}]
}),
10]

eqns=#==0&/@rels;

vars=Union[Cases[eqns,(Subscript[c, d,_]),∞]]

sol=Solve[eqns,vars][[1]]

sol/.Rule->Set

(Subscript[c, 7,9])=0

Φ[d]

PrintProfile[]

Solving to Degree 8

d=8; i=0;
Φ[d]=Φ[d-1]+Sum[(Subscript[c, d,++i])B,{B,Select[(Subscript[Basis, d])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]}]

Short[
rels=Union@@(List@@(Subscript[Pentagon, d])[Φ[d]][[1]]/.{
(Subscript[𝒜, 0])[A_]:>Table[Coefficient[A,B],{B,(Subscript[Basis, d,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}],
(Subscript[𝒜, c[1,2]])[A_]:>Table[Coefficient[A,B],{B,(Subscript[AW, (OverBar[1])])[](Subscript[AW, (OverBar[2])])[](Subscript[Basis, d-1,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}]
}),
10]

eqns=#==0&/@rels;

vars=Union[Cases[eqns,(Subscript[c, d,_]),∞]]

sol=Solve[eqns,vars][[1]]

sol/.Rule->Set

(Subscript[c, 8,6])=-(13/3628800)

Φ[d]

PrintProfile[]

Solving to Degree 9

d=9; i=0;
Φ[d]=Φ[d-1]+Sum[(Subscript[c, d,++i])B,{B,Select[(Subscript[Basis, d])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]}]

Short[
rels=Union@@(List@@(Subscript[Pentagon, d])[Φ[d]][[1]]/.{
(Subscript[𝒜, 0])[A_]:>Table[Coefficient[A,B],{B,(Subscript[Basis, d,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}],
(Subscript[𝒜, c[1,2]])[A_]:>Table[Coefficient[A,B],{B,(Subscript[AW, (OverBar[1])])[](Subscript[AW, (OverBar[2])])[](Subscript[Basis, d-1,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}]
}),
10]

eqns=#==0&/@rels;

vars=Union[Cases[eqns,(Subscript[c, d,_]),∞]]

sol=Solve[eqns,vars][[1]]

sol/.Rule->Set;

(Subscript[c, 9,2])=0;

Φ[d]

PrintProfile[]

Solving to Degree 10

d=10; i=0;
Φ[d]=Φ[d-1]+Sum[(Subscript[c, d,++i])B,{B,Select[(Subscript[Basis, d])[(Subscript[𝕆, HR,{x,y},{1}])], FreeQ[#,(Subscript[𝒜, c[1]])]&]}]

Short[
rels=Union@@(List@@(Subscript[Pentagon, d])[Φ[d]][[1]]/.{
(Subscript[𝒜, 0])[A_]:>Table[Coefficient[A,B],{B,(Subscript[Basis, d,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}],
(Subscript[𝒜, c[1,2]])[A_]:>Table[Coefficient[A,B],{B,(Subscript[AW, (OverBar[1])])[](Subscript[AW, (OverBar[2])])[](Subscript[Basis, d-1,{x,y}])[(Subscript[AW, 1])(Subscript[AW, 2])]}]
}),
10]

eqns=#==0&/@rels;

vars=Union[Cases[eqns,(Subscript[c, d,_]),∞]]

sol=Solve[eqns,vars][[1]]

sol/.Rule->Set;

Φ[d]

Cases[Φ[d],(Subscript[c, __]),∞]//Union

PrintProfile[]