<<Combinatorica`

Get[NotebookDirectory[]<>"mathmzv2.m"];

IIzero[a_List] := Module[{}, (
If[(Length[a] ≥ 3 && a[[1]] == a[[-1]]) ||
(Length[a]≥3 && VectorQ[a[[2;;-2]], #==0&]) ||
(Length[a]≥3 && VectorQ[a[[2;;-2]], #==1&]),
	Return[0],
Return[IIi[a]]
];
)];

IIrev[a_List] := Module[{}, (
If[a[[1]] == 1 && a[[-1]]==0,
Return[(-1)^Length[a]IIi[Reverse[a]]],
Return[IIi[a]]
];
)];

IIfunc[a_List] := Module[{}, (
If[a[[2]] == 1 && a[[-2]]==1,
Return[IIi[1-Reverse[a]]],
Return[IIi[a]]
];
)];

IIreg[a_List] := Module[{pos,nk,comp,sum},(
pos=Differences[Join[{2},Flatten[Position[a,1]]]];
nk=Rest[pos];
comp=Compositions[pos[[1]],Length[nk]];
sum=(-1)^pos[[1]]*Sum[(Times@@(Binomial[nk[[#]]+comp[[i,#]]-1,comp[[i,#]]]&/@Range[Length[nk]]))*((zetaToIntegral[(nk+comp[[i]])])),{i,1,Length[comp]}];
Return[(sum)]
)];

R1 = (#/.IIi->IIzero//Expand)&;
R2 = (#/.IIi->IIreg//Expand)&;
R3 = (#/.IIi->IIrev//Expand)&;
R4 = (#/.IIi->IIfunc//Expand)&;

simp = (#//R1//R3//R2//R4//R2//toZ)&;

evalZ = (#/.zAi->z)&;

(* ------- *)

integralToZeta[l:{0, 1, ___, 0, 1}] := (-1)^(Count[l,1]-1)zAi[Differences[Position[l, 1]]//Flatten]

zetaToIntegral[l_List] := (-1)^Length[l] * IIi[Join[{0}, Flatten[Join[{1}, Table[0, {#-1}]]&/@l], {1}]];

toZ = (#/.IIi->integralToZeta//Expand)&;
toI = (#/.zAi->zetaToIntegral//Expand)&;

listFirstBlock[{Shortest[s___], a_, a_, t___}] := {{s,a},{a,t}};
listFirstBlock[l_List] := {l, {}};

integralToBlocks[lin_List] := Block[{l, l0, blocks}, (
l = lin;

blocks = Reap[While[True,
l = listFirstBlock[l];
l0 = l[[1]];
l=l[[2]];
Sow[l0];
If[l==={}, Break[]];
]][[2,1]];
Return[BBi[Length/@blocks]];
)];

zeroOneBlock[l_Integer/;l>0] := Table[(1 + (-1)^i)/2, {i, 1, l}];
oneZeroBlock[l_Integer/;l>0] := 1 - zeroOneBlock[l];
makeBlock[l_Integer/;l>0, startDigit_] := If[startDigit == 0, zeroOneBlock[l], oneZeroBlock[l]];

blocksToIntegral[lin_List] := Block[{startDigit,l,i,lout, block}, (
l = lin;
startDigit = 0;

lout = Reap[For[i = 1, i ≤ Length[lin], i++,
block = makeBlock[l[[i]], startDigit];
startDigit = block[[-1]];
Sow[block];
]][[2,1]];

Return[IIi[Flatten[lout]]];
)];

toB = (#/.IIi->integralToBlocks//Expand)&;
fromB = (#/.BBi->blocksToIntegral//Expand)&;

cycles[l_List] := Table[Join[Drop[l,n], Take[l, n]], {n, 1, Length[l]}]

(* ------- *)

weight = 14;

d[1] = 0;
d[2] = 1;
d[3] = 1;
d[k_] := d[k-2] + d[k-3];

basis = Union[Flatten[Permutations/@Partitions[weight],1]]//DeleteCases[#,{___, 1}]&;

basgen[k_,n_] := Table[If[i==k,1,0], {i, 1, n}];

lookup[zAi[l_List]] := Module[{pos}, (
pos = Position[basis,l,1];
If[pos === {}, Return[$Error]];
Return[basgen[pos[[1,1]], Length[basis]]];
)];

(basis//Length) - d[weight]

lookupZ[expr_] := expr/.zAi[l_List]:>lookup[zAi[l]]

(* ----------- *)

parts = Flatten[Permutations/@Partitions[weight+2],1]//DeleteCases[#, el_/;Mod[(Plus@@el) + Length[el],2]==0]&;

goodparts = DeleteCases[parts,{___, 1, 1, ___}|{1, ___, 1}];

badparts = DeleteCases[parts, Except[{___, 1, 1, ___}|{1, ___, 1}]];

partsGATH = GatherBy[parts, Sort[Permutations[#]][[1]]&][[All,1]];

badpartsGATH = GatherBy[badparts, Sort[Permutations[#]][[1]]&][[All,1]];

goodpartsGATH = GatherBy[goodparts, Sort[cycles[#]][[1]]&][[All,1]];

goodpartsGATH//Length

badpartsGATH//Length

(* --------------- *)

interleave[l1_List, l2_List] := Riffle[l1, l2];

altodd[lin_List]/;OddQ[Length[lin]] := Module[{l, lodd, leven, loddperm, sum}, (
l = lin;
lodd = Range[1, Length[l], 2];
leven = Range[2, Length[l], 2];
loddperm = {Signature[#], #}&/@Permutations[lodd];
sum = Sum[loddperm[[i,1]]BBi[l[[interleave[loddperm[[i,2]], leven]]]], {i, 1, Length[loddperm]}];
Return[sum];
)];

altoddperms[lin_List]/;OddQ[Length[lin]] := {Sort[lin[[Range[1, Length[lin], 2]]]], lin[[Range[2, Length[lin],2]]]}

repeatedodd[lin_List]:= Max[Tally[lin[[Range[1, Length[lin], 2]]]][[All,2]]]≥2;

partsALTODD = GatherBy[parts, altoddperms][[All,1]];

partsALTODDres = DeleteCases[partsALTODD, el_/;repeatedodd[el]||Length[el]≤3];

altoddRELS = (altodd/@partsALTODDres)//fromB//simp//DeleteCases[#, 0]&;

altoddRELS//Length

altoddMATRIX = altoddRELS//lookupZ;

altoddRELS//evalZ//Rationalize

altoddMATRIX//Length

MatrixRank[altoddMATRIX]

sumPerms[l_List] := ((Plus@@(BBi[#]&/@Permutations[l]))//fromB//simp//evalZ)

sumCycle[l_List] := ((Plus@@(BBi[#]&/@cycles[l]))//fromB//simp//evalZ)

sumPermsInert[l_List] := ((Plus@@(BBi[#]&/@Permutations[l]))//fromB//simp)

sumCycleInert[l_List] := ((Plus@@(BBi[#]&/@cycles[l]))//fromB//simp)

(* ---------------- *)

aszeta222[wt_, v_]/;Mod[wt,2]==0 := Rationalize[v/(Pi^wt / (wt+1)!)]*zAi[Table[2, {wt/2}]];
aszeta222[wt_, v_]/;Mod[wt,2]!=0 := $Error;

makePermIdentity[l_List] := (# - aszeta222[(Plus@@l)-2,evalZ[#]])&@sumPermsInert[l]

makeCycleIdentity[l_List] := (# - aszeta222[(Plus@@l)-2,evalZ[#]])&@sumCycleInert[l]

makeDuality[b_] := ((IIi[#] -IIi[Reverse[1-#]])&@(Join[{0,1},IntegerDigits[b, 2, weight-2],{0,1}])//simp)

cycleRels = Map[makeCycleIdentity, goodpartsGATH, 1]//DeleteCases[#, 0]&//lookupZ;

makeCycleIdentity[goodpartsGATH[[1]]]

cycleRels//MatrixRank

cycleRels//Length

permRels = Map[makePermIdentity, badpartsGATH, 1]//DeleteCases[#, 0]&//lookupZ;

permRels//Length

badpartsGATH//Length

MatrixRank[Join[permRels,cycleRels]]

dualityRels = Map[makeDuality, Range[0,2^(weight-2)-1],1]//DeleteCases[#, 0, 1]&//lookupZ;

allrels = Join[dualityRels,cycleRels, permRels,altoddMATRIX];

{weight, MatrixRank[Join[cycleRels, permRels,altoddMATRIX]],MatrixRank[dualityRels],MatrixRank[allrels], Length[basis] - d[weight]}

%//ToString//StringReplace[#, {"{"->"", ", "->" & ","}"->" \\\\"}]&

NotebookSave[];

{Length[badpartsGATH],Length[goodpartsGATH]}

(zAi[#]&/@basis).#&/@permRels//evalZ

(zAi[#]&/@basis).#&/@cycleRels//evalZ

NotebookSave[]