(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



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_] :> \!\(
\*UnderoverscriptBox[\(\[Sum]\), \(j = 1\), \(n\)]\(b[LW@
\*SubscriptBox[\(x\), \(i\)], LW@
\*SubscriptBox[\(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\[LeftDoubleBracket]i\[RightDoubleBracket]}, c_.*v[j_] \[RuleDelayed]  ({i,j}\[Rule]c),\[Infinity]],
Wrong! c_.*v[j_] matches some terms twice, producing extra matrix entries. *)
vc=im[[i]];
({i,#[[1]]} ->  Coefficient[vc, #])& /@ Cases[{vc}, _v, \[Infinity]],
{i,Length[im]}]],
{Length[im], tdim}]
]
]
]


PrimitivesToFull[p_List] := Module[
{lp, h, ser},
lp = Length[p];
ser = Normal[Series[\!\(
\*UnderoverscriptBox[\(\[Product]\), \(k = 1\), \(lp\)]
\*SuperscriptBox[\((
\*FractionBox[\(1\), \(1 - 
\*SuperscriptBox[\(h\), \(k\)]\)])\), \(p[[k]]\)]\),{h, 0, lp}]];
Table[Coefficient[ser, h, i], {i,0, lp}]
];



