These are the Mathematica solutions for the paper:

“Permutation-type solutions to the Yang-Baxter and other n-simplex equations” by J. Hietarinta.

computations by Dara O Shayda

dara@lossofgenerality.com

<<Notation`

This formulation is incomprehensible and I guessed how it works:

Notation[(NotationTemplateTag[(Subscript[R, i_,j_])]) ⟹ (NotationTemplateTag[makeA[A,{i_,j_},3]])]
Notation[(NotationTemplateTag[(Subscript[R, i_,j_,k_])]) ⟹ (NotationTemplateTag[makeA[A,{i_,j_,k_},6]])]
Notation[(NotationTemplateTag[(Subscript[R, i_,j_,k_,h_])]) ⟹ (NotationTemplateTag[makeA[A,{i_,j_,k_,h_},10]])]

makeMatrix[dim_, a_]:=Array[Subscript[a,#1,#2]&,dim]

(* makeA generates the A matrices in Hietarinta paper *)

makeA[A_, list_,n_]:=Module[{res, i,j,k},

res=ConstantArray[-1,{n,n}];

Table[If[MemberQ[list, i]!= True, res [[i]][[j]]=KroneckerDelta[i,j]; res [[j]][[i]]=KroneckerDelta[j,i] ], {i, 1, n}, {j, 1, n}];
 
Table[k=1;Table[ If[res[[list[[i]]]][[j]] == -1, res[[list[[i]]]][[j]] = A[[i]][[k]];k=k+1];,{j,1,n}],{i , 1, Length[list]}];
res

]

3-Simplex

A=makeMatrix[{3,3},a];
A//MatrixForm

Rename the entries to match the paper:

A= A/.{(Subscript[a, 1,1])->a, (Subscript[a, 1,2])->b, (Subscript[a, 1,3])->c, (Subscript[a, 2,1])->x, (Subscript[a, 2,2])->y, (Subscript[a, 2,3])->z, (Subscript[a, 3,1])->u, (Subscript[a, 3,2])->v, (Subscript[a, 3,3])->w};
A//MatrixForm

Make the R matrices for 3-implex:

(Subscript[R, 1,2,3])  //MatrixForm

(Subscript[R, 1,4,5]) // MatrixForm

(Subscript[R, 2,4,6])  //MatrixForm

(Subscript[R, 3,5,6]) //MatrixForm

eqs=((Subscript[R, 1,2,3]).(Subscript[R, 1,4,5]).(Subscript[R, 2,4,6]).(Subscript[R, 3,5,6])- (Subscript[R, 3,5,6]).(Subscript[R, 2,4,6]).(Subscript[R, 1,4,5]).(Subscript[R, 1,2,3]));
((Subscript[R, 1,2,3]).(Subscript[R, 1,4,5]).(Subscript[R, 2,4,6]).(Subscript[R, 3,5,6])- (Subscript[R, 3,5,6]).(Subscript[R, 2,4,6]).(Subscript[R, 1,4,5]).(Subscript[R, 1,2,3])) // MatrixForm

We get exactly the same equations.

Solve these simultaneous system of equations, ‘->’ means substitute for solution:

Make a list of the polynomials from the R equations:

eqs=DeleteDuplicates[DeleteCases[Flatten[eqs], _Integer]]

Find the Groebner basis, this set has the same  gb roots as eqs:

gb=GroebnerBasis[eqs, {a,b,c,x,y,z,u,v,w}]

Seems the same i.e. same difficulties to solve.  


Use Groebner basis to eliminate some vars:

(* did not work *)
gbasis=GroebnerBasis[eqs, {a,b,c},{x,y,z,u,v,w}]

Works this time and we have much fewer equations by elimination:

gbasis=GroebnerBasis[eqs, {a,b,c,x},{y,z,u,v,w}]

Solve for 0s:

Solve[gbasis==0, {a,b,c,x}]

Now we can classify:


Case:{x->0}

sol=Solve[DeleteDuplicates[DeleteCases[Simplify[eqs/.{x->0}],_Integer]]==0,{a,b,c,y,z,u,v,w} ];

Table[(A/.{x->0})/.sol[[i]]//MatrixForm, {i, 1, Length[sol]}]

Case:{b->0,c->0}

sol=Solve[DeleteDuplicates[DeleteCases[Simplify[eqs/.{b->0,c->0}],_Integer]]==0,{a,x,y,z,u,v,w} ];

Table[(A/.{b->0,c->0})/.sol[[i]]//MatrixForm, {i, 1, Length[sol]}]

Case:{a->0,b->1,x->1}

sol=Solve[DeleteDuplicates[DeleteCases[Simplify[eqs/.{a->0,b->1,x->1}],_Integer]]==0,{c,y,z,u,v,w} ];

Table[(A/.{a->0,b->1,x->1})/.sol[[i]]//MatrixForm, {i, 1, Length[sol]}]