# 3D-graphing the $E_8$ root system/ $4_{21}$ polytope

I'm trying to recreate on Mathematica the 3D graphs $$4_{21}$$ polytope as seen here and here.

My idea would be to obtain a 3D-graph so that I can then add some thickness to the edges and export it as a STL file.

I think I managed to produce the $$4_{21}$$ using this code I've found here:

    (Permutation funtctions)
pm@n_ := Flatten[Outer[List, Sequence @@ Table[{-1, 1}, {n}]], n - 1];
perms8[{a_, b_, c_, d_, e_, f_, g_, h_}] :=
Flatten[Permutations@{a #1, b #2, c #3, d #4, e #5, f #6, g #7,
h #8} & @@@ pm@8, 1];
Eperms8@in_ := Select[perms8@in, EvenQ@Count[Sign@#, -1] &];

( E8 4_21 vertices scaled for Max Norm=1 from Unimodular C600 and \
it's 3D E8->H4 projection basis)
e8421 =\[CapitalPhi] Union@
Join[Eperms8@{1, 1, 1, 1, 1, 1, 1, 1}/2,
perms8@{1, 1, 0, 0, 0, 0, 0, 0}](**)/Sqrt[2](**);
Length@%


I'm not sure how to move from here onwards...

## 1 Answer

Here's a brute-force method for generating a 3D embedding of the graph of the $$4_{21}$$ polytope:

verts = Join[Union[Flatten[Permutations /@
Join[PadRight[Tuples[{-2, 2}, 2], {Automatic, 8}],
PadRight[Table[ConstantArray[-1, 2 k], {k, 3}],
{Automatic, 8}, 1]], 1]],
{ConstantArray[-1, 8], ConstantArray[1, 8]}];
edges = Select[Position[DistanceMatrix[verts] - Sqrt[8], 0], Apply[Less]];

Graph3D[Range[Length[verts]], UndirectedEdge @@@ edges]


It looks quite a bit messy, so I'm not sure about the feasibility of 3D-printing something from this version. Hopefully, other people can build and improve on this...