FindDegree[expr_,k_:4]:=Length[CoefficientList[Expand[expr]/.Table[Symbol["x"<>ToString[i]]->x1,{i,1,k}],x1]]-1
DividedPowerExp[gen_,poly_,acc_,start_:0]:=ClipPoly[Product[1+b[2^i]poly^(2^i),{i,start,Log[2,acc/FindDegree[poly]]//Ceiling}],acc]
ReduceBs[series_]:=Expand[series]/.{b^(n_)/;n>1->0}
ExpVars[in_]:=Exponent[in,Select[Variables[in],With[{name=ToString[#]},(StringTake[name,1]=="x"&&NumberQ[ToExpression[StringDrop[name,1]]])||name=="t"]&]]
ClipPoly[p_,deg_]:=With[{temp=Select[(p//Expand)/.Plus->List,Plus@@ExpVars[#]<=deg&]},If[Head[temp]===List,Plus@@temp,temp]]
InversePoly[p_,accuracy_]:=ClipPoly[With[{deg=Min[(Plus@@ExpVars[#])&/@Rest[(p//Expand)/.Plus->List]],x=-(p-1)},1+Sum[(If[SameQ[Head[#],List],Plus@@#,#]&@Select[Expand[x]/.Plus->List,(Plus@@ExpVars[#])+(i-1) deg<=accuracy&])^i,{i,Floor[accuracy/deg]}]],accuracy]
ArtinHasse[t_,acc_,root_]:=Plus@@With[{innards=Sum[t^(2^k)/2^(k+root)//Expand,{k,0,acc}]},Fold[Join[#1,{ClipPoly[Last[#1]*innards/#2,acc]}]&,{1},Range[1,acc]]]
Delta1[poly_,k_,acc_]:=With[{rules=Join[Table[Symbol["x"<>ToString[i]]->Symbol["x"<>ToString[i+1]],{i,2,4}],{#}]&/@{x1->x1,x1->x2,x1->x1+x2}},With[{subs=Expand[poly/.#]&/@rules},ClipPoly[ClipPoly[subs[[3]]*InversePoly[subs[[1]],acc*2],acc]*InversePoly[subs[[2]],acc*2],acc]]]
ClippedCoaction[x_,n_,acc_]:=(x+Sum[x^(2^i)xi[i],{i,1,Log[2,acc-n+1]}])^n
UniversalCoaction[p_,acc_]:=Release[Hold[p]/.x_^n_/;With[{name=ToString[x]},NumberQ[ToExpression[StringDrop[name,1]]]&&StringTake[name,1]=="x"]:>ClippedCoaction[ToExpression["z"<>StringDrop[ToString[x],1]],n,acc]]/.x_/;With[{name=ToString[x]},NumberQ[ToExpression[StringDrop[name,1]]]&&StringTake[name,1]=="x"]:>ClippedCoaction[ToExpression["z"<>StringDrop[ToString[x],1]],1,acc]/.x_/;With[{name=ToString[x]},NumberQ[ToExpression[StringDrop[name,1]]]&&StringTake[name,1]=="z"]:>ToExpression["x"<>StringDrop[ToString[x],1]]
MakePoly[exps_]:=Plus@@(Times@@Table[Symbol["x"<>ToString[i]]^#[[i]],{i,1,Length[#]}]&/@Permutations[exps])

Nub[list_]:=Fold[If[MemberQ[#1,#2],#1,Append[#1,#2]]&,{},list]
padicDistance[n_,k_]:=Max[k-(Plus@@IntegerDigits[n,2]),0]
BuildFreeClass[n_,k_,acc_,coeff_]:=PolynomialMod[Fold[Delta1[#1,#2,acc]&,ArtinHasse[t,acc,padicDistance[n,k]]/.t->coeff x1^n,Range[1,k-1]],2]
HandleNextFreeClass[class_,k_,acc_]:=With[{nextdegree=#[[1,1]],coeff=#[[1,2]]},Print[{nextdegree,coeff}];PolynomialMod[ClipPoly[class*                         InversePoly[BuildFreeClass[nextdegree,k,acc,coeff],acc],acc],2]]&@Nub[Fold[Which[#1[[1,1]]>#2[[1]],{#2},#1[[1,1]]==#2[[1]],Join[#1,{#2}],True,#1]&,{{Infinity,0}},{FindDegree[#,k],#}&/@(If[SameQ[Head[(class-1)/.Plus->List],List],(class-1)/.Plus->List,{class-1}])]/.Table[Symbol["x"<>ToString[i]]->1,{i,1,k}]]
IterateFreeClass[class_,k_,acc_]:=If[SameQ[#,1],1,IterateFreeClass[#,k,acc]]&@HandleNextFreeClass[class,k,acc]
DissectFreeClass[n_,k_,acc_]:=With[{phiInitial=PolynomialMod[ClipPoly[UniversalCoaction[BuildFreeClass[n,k,acc,a],acc],acc],2]},IterateFreeClass[phiInitial,k, acc]]

MakeExponentList[poly_,k_]:=With[{vars=Table[Symbol["x"<>ToString[i]],{i,1,k}]},{#/Times@@(vars^Exponent[Rest[#],vars]),Sort[Exponent[Rest[#],vars]]}&/@#&/@If[Head[poly]===List,(Expand[poly]/.Plus->List),Expand[{poly}]/.Plus->List]]
FindNewestClass[n_,k_]:=(Join@@MapIndexed[Table[2^(#2[[1]]-1),{i,1,#1}]&,Nest[With[{target=Position[#//Rest,x_/;x!=0,1,1][[1,1]]+1},Join[Take[#,{1,target-2}],{#[[target-1]]+2},{#[[target]]-1},Take[#,{target+1,Length[#]}]]]&,IntegerDigits[n,2]//Reverse,Max[k-(Plus@@IntegerDigits[n,2]),0]]])//Sort
BuildDPClass[exp_,coeff_]:=1+coeff MakePoly[exp]//Expand
HandleNextDPClass[class_,k_,acc_]:=With[{fnc=FindNewestClass[Plus@@#[[1,2]],k]},Which[FreeClassQ[Plus@@#[[1,2]],k]&&Position[#,x_/;x==fnc]!={},Print[{"free class",#}];1PolynomialMod[ReduceBs[ClipPoly[InversePoly[PolynomialMod[BuildFreeClass[Plus@@#[[1,2]],k,acc,#[[Position[#,x_/;x==fnc][[1,1]],1]]]//ReduceBs,2],acc]*class,acc]],2],True,Print[{"DP classes",#}];PolynomialMod[ReduceBs[ClipPoly[class*InversePoly[ReduceBs[Times@@(BuildDPClass[#[[2]],#[[1]]]&/@#)],acc],acc]],2]]]&@Nub[Fold[Which[Plus@@#1[[1,2]]>Plus@@#2[[2]],{#2},Plus@@#1[[1,2]]==Plus@@#2[[2]],Join[#1,{#2}],True,#1]&,{{0,{Infinity}}},MakeExponentList[class-1,k][[1]]]]
IterateDPClass[class_,k_,acc_]:=With[{next=HandleNextDPClass[class,k,acc]},If[SameQ[next,1],1,IterateDPClass[next,k,acc]]]
FreeClassQ[n_,k_]:=padicDistance[n,k]<=IntegerExponent[n,2]
DissectDPClass[exp_,acc_]:=With[{phiInitial=PolynomialMod[ClipPoly[UniversalCoaction[BuildDPClass[exp,b],acc],acc],2]},IterateDPClass[phiInitial,Length[exp],acc]]

Print["loaded"]