Pensieve header: Infinitemial Elliptic computations, version Lie.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2015-02\\InfinitesimalElliptic"];
<< FreeLieBasic.m

AllLyndonWords[n_,d_Integer]:= AllLyndonWords[d, Union@@Table[{(Subscript[x, i]),(Subscript[y, i])}, {i,n}]]

AllRelators2[n_]:=Flatten[{
Table[{(Subscript[cx, i,j]),(Subscript[cy, i,j]),(Subscript[cxy, i,j])}, {i,1,n-1},{j,i+1,n}],
Table[(Subscript[c, n,i]),{i,n}]
}];
AllRelators3[n_] := Flatten[Table[
{(Subscript[ctx, i,j,k]),(Subscript[cty, i,j,k]),(Subscript[ctx, j,k,i]),(Subscript[cty, j,k,i]),(Subscript[ctx, k,i,j]),(Subscript[cty, k,i,j])},
{i,1,n-2},{j,i+1,n-1},{k,j+1,n}
]];

ad[AW[],x_] := x;
ad[AW[lft___,g_],x_] := ad[AW[lft],b[LW[g],x]];

AllWords[n_,d_]:=AW@@@Tuples[Union@@Table[{(Subscript[x, i]),(Subscript[y, i])}, {i,n}], d];
AllRelators2[n_,d_] /; d<2:={};
AllRelators2[n_,d_] :=Flatten[ Outer[ad, AllWords[n,d-2],LW/@AllRelators2[n]]];
AllRelators3[n_,d_] /; d<3:={};
AllRelators3[n_,d_] :=Flatten[ Outer[ad, AllWords[n,d-3],LW/@AllRelators3[n]]];
AllRelators[n_,d_] := Join[AllRelators2[n,d], AllRelators3[n,d]];

LieMorphism[diff, {
LW@(Subscript[cx, i_,j_]):>b[LW@(Subscript[x, i]),LW@(Subscript[x, j])], LW@(Subscript[cy, i_,j_]) :> b[LW@(Subscript[y, i]),LW@(Subscript[y, j])],
LW@(Subscript[cxy, i_,j_]) :> b[LW@(Subscript[x, i]),LW@(Subscript[y, j])]-b[LW@(Subscript[x, j]),LW@(Subscript[y, i])],
LW@(Subscript[ctx, i_,j_,k_]) :> b[b[LW@(Subscript[x, i]),LW@(Subscript[y, j])],LW@(Subscript[x, k])],
LW@(Subscript[cty, i_,j_,k_]) :> b[b[LW@(Subscript[x, i]),LW@(Subscript[y, j])],LW@(Subscript[y, k])],
LW@(Subscript[c, n_,i_]) :> (∑_(j=1)^n)b[LW@(Subscript[x, i]),LW@(Subscript[y, j])]
}];

Dim[n_,d_] := Dim[n,d] = Module[{bas,tdim,im,v,vc},
tdim=Length[bas=AllLyndonWords[n,d]];
im=(diff/@AllRelators[n,d]) /. Thread[bas -> Table[v[i], {i,tdim}]];
If[im=={},
tdim,
tdim-MatrixRank[
SparseArray[
Flatten[Table[
(*Cases[{im[[i]]}, c_.*v[j_] :>  ({i,j}->c),∞],
Wrong! c_.*v[j_] matches some terms twice, producing extra matrix entries. *)
vc=im[[i]];
({i,#[[1]]} ->  Coefficient[vc, #])& /@ Cases[{vc}, _v, ∞],
{i,Length[im]}]],
{Length[im], tdim}]
]
]
]

PrimitivesToFull[p_List] := Module[
{lp, h, ser},
lp = Length[p];
ser = Normal[Series[(∏_(k=1)^lp)((((1/(1-(h^k)))))^(p[[k]])),{h, 0, lp}]];
Table[Coefficient[ser, h, i], {i,0, lp}]
];

PrimitivesToFull[Table[Dim[2,d], {d,7}]] // Timing

PrimitivesToFull[Table[Dim[3,d], {d,6}]] // Timing

(3^(Range[10]))

PrimitivesToFull[Table[Dim[4,d], {d,4}]] // Timing

Testing

AllLyndonWords[5,{1,2}] // TopBracketForm

AllLyndonWords[2,3] // Length

ad[AW[1,1,1,1,1,1],LW[2]]

ad[AW[2,2,2,2,2],LW[1]]

ad[AW[2,2,1,2,1,2],LW[1]]

{AllRelators2[3,3], AllRelators3[3,3]}

diff[AllRelators[3,3]]

Dim[3,3]

Dim[2,1]

Dim[2,2]

PrimitivesToFull[Table[Dim[1,d], {d,6}]]

Table[Dim[1,d], {d,6}]

dd=7; Table[Dim[2,d], {d,dd}]-Table[Dim[1,d], {d,dd}]

dd=6; Table[Dim[3,d], {d,dd}]-Table[Dim[2,d], {d,dd}]

PrimitivesToFull@{2,2,4,7,16,30}