2
$\begingroup$

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...

$\endgroup$

1 Answer 1

5
$\begingroup$

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]

4_21 polytope

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...

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.