Pensieve Header: The Polyak Algebra.

R8T

SetAttributes[Diag, Orderless];
Place[{Ar},{i_, j_}] := {Diag[Ar[i,j]], Diag[Ar[j,i]]};
Place[{Ar, objs__}, {i_, rest__}] := Flatten[Table[
Outer[Join,
Place[{Ar}, {i, {rest}[[k]]}],
Place[{objs}, Delete[{rest}, k]]
],
{k, Length[{rest}]}
]];
Diagrams[k_.*Ar]  := Place[Table[Ar, {k}], Range[2k]]

Place[{R8T},{i_, j_, k_}] := Permutations[{i,j,k}] /. {i1_,j1_,k1_} :> Diag[R8T[i1,j1,k1]];
Place[{r:(TC|R8T), objs__}, {i_, rest__}] := Flatten[Table[
Outer[Join,
Place[{r}, {i, {rest}[[j]], {rest}[[k]]}],
Place[{objs}, Delete[{rest}, {{j}, {k}}]]
],
{k, 2, Length[{rest}]}, {j,1, k-1}
]];
Diagrams[R8T] := Place[{R8T}, {1,2,3}];
Diagrams[R8T+k_.*Ar] /; k>0 := Flatten[
Place[#, Range[2k+3]]& /@ Permutations[Table[Ar, {k}]~Append~R8T]
];
Place[{TC},{i_, j_, k_}] := Diag /@ {TC[i,j,k], TC[j,k,i], TC[k,i,j]};
Diagrams[TC] := Place[{TC}, {1,2,3}];
Diagrams[TC+k_.*Ar] /; k>0 := Flatten[
Place[#, Range[2k+3]]& /@ Permutations[Table[Ar, {k}]~Append~TC]
];
Diagrams[TC+k_.*Ar] /; k<0 := {};

NormalizeDiag[diag_Diag] := Module[
{indices = Union@@ (List @@ diag /. Ar -> List)},
diag /. Thread[indices -> Range[Length[indices]]]
];
R[Diag[lft___, R8T[i_,j_,k_], rgt___]] := (
(* RHS of (9) *)
NormalizeDiag[Diag[lft, Ar[i,j], Ar[i+0.5, k], Ar[j+0.5, k+0.5], rgt]]
+NormalizeDiag[Diag[lft, Ar[i,j], Ar[i+0.5, k], rgt]]
+NormalizeDiag[Diag[lft, Ar[i,j], Ar[j+0.5, k], rgt]]
+NormalizeDiag[Diag[lft, Ar[i,k], Ar[j, k+0.5], rgt]]
(* LHS of (9) *)
-NormalizeDiag[Diag[lft, Ar[j, k], Ar[i,k+0.5], Ar[i+0.5, j+0.5], rgt]]
-NormalizeDiag[Diag[lft, Ar[i,k], Ar[i+0.5, j], rgt]]
-NormalizeDiag[Diag[lft, Ar[i,j+0.5], Ar[j, k], rgt]]
-NormalizeDiag[Diag[lft, Ar[i,k+0.5], Ar[j, k], rgt]]
);
RMinus[n_, Diag[lft___, R8T[i_,j_,k_], rgt___]] := Module[
{Expand2, Expand3, n1},
n1=n-Length[{lft, rgt}];
Expand2[Diag[Ar[i1_,j1_], Ar[i2_,j2_]]] := Sum[
(-1)^(k1+k2) * NormalizeDiag[Flatten[Diag[
lft,
Diag@@Table[Ar[i1+0.01q, j1+0.01q],{q, k1}],
Diag@@Table[Ar[i2+0.01q, j2+0.01q],{q, k2}],
rgt
]]],
{k1, n1-1}, {k2, n1-k1}
];
Expand3[Diag[Ar[i1_,j1_], Ar[i2_,j2_], Ar[i3_,j3_]]] := Sum[
(-1)^(k1+k2+k3) * NormalizeDiag[Flatten[Diag[
lft,
Diag@@Table[Ar[i1+0.01q, j1+0.01q],{q, k1}],
Diag@@Table[Ar[i2+0.01q, j2+0.01q],{q, k2}],
Diag@@Table[Ar[i3+0.01q, j3+0.01q],{q, k3}],
rgt
]]],
{k1, n1-2}, {k2, n1-k1-1}, {k3,n1-k1-k2}
];
Expand[Plus[
(
Diag[Ar[i,j], Ar[i+0.5, k]]+Diag[Ar[i,j], Ar[j+0.5, k]]+Diag[Ar[i,k], Ar[j, k+0.5]]
-Diag[Ar[i,k], Ar[i+0.5, j]]-Diag[Ar[i,j+0.5], Ar[j, k]]-Diag[Ar[i,k+0.5], Ar[j, k]]
) /. d_Diag :> Expand2[d],
(Diag[Ar[i,j], Ar[i+0.5, k], Ar[j+0.5, k+0.5]] - Diag[Ar[j, k], Ar[i,k+0.5], Ar[i+0.5, j+0.5]]) /. d_Diag:> Expand3[d]
]]
];
R[Diag[lft___, TC[i_,j_,k_], rgt___]] := (
+NormalizeDiag[Diag[lft, Ar[k,i], Ar[k+0.5, j], rgt]]
-NormalizeDiag[Diag[lft, Ar[k+0.5, i], Ar[k, j], rgt]]
);
ContainsShortArrow[diag_Diag] := (1==Min[List@@diag /. Ar[i_,j_] :> Abs[i-j]]);

DimP[m_] /; m<2 := Length[Diagrams[m Ar]];
DimP[m_, reltypes_List] /; m≥2 := Module[
{diags, rels, diagtoindex, mat, rel, i},
Print[Date[], ": Starting work..."];
diags=Join@@Table[Diagrams[k Ar], {k,m}];
reltypes /. "R1" :> (
diags = Select[diags, !ContainsShortArrow[#]&]
);
Print[Date[], ": Computed ",Length[diags]," diagrams..."];
rels = Join@@(reltypes /. {
"R1" -> {},
"R8T" :> (
(R /@ Join@@Table[Diagrams[R8T+k Ar], {k, 0, m-2}]) /.diag_Diag /; Length[diag]>m :> 0
),
"R8TMinus" :> (
RMinus[m, #]& /@ Join@@Table[Diagrams[R8T+k Ar], {k, 0, m-2}]
),
"TC" :> (
R /@ Join@@Table[Diagrams[TC+k Ar], {k, 0, m-2}]
)
});
reltypes /. "R1" :> (
rels = rels /. {d_Diag /; ContainsShortArrow[d] :> 0}
);
Print[Date[], ": Computed ",Length[rels]," relations..."];
diagtoindex = Dispatch[Thread[Rule[diags, Range[Length[diags]]]]];
mat = SparseArray[
Join @@ Table[
rel=rels[[i]];
{i,# /. diagtoindex} -> Coefficient[rel, #]& /@ Cases[{rel}, diag_Diag, Infinity],
{i,Length[rels]}
],
{Length[rels], Length[diags]}
];
Print[Date[], ": Computed mat..."];
Length[diags]-MatrixRank[mat]
];

DimP[#, {"R8T"}]& /@ {2,3,4}

DimP[#, {"R8T", "R8TMinus"}]& /@ {2,3,4}

DimP[#, {"R8T", "R1"}]& /@ {2,3,4, 5}

DimP[#, {"R8T", "TC"}]& /@ {2,3,4}

DimP[#, {"R8T", "TC", "R1"}]& /@ {2,3,4}