How to visualize a Cayley graph in this style?

Question

I'm trying to create a similar style of image like this one, which is the Cayley graph of $A_{5}$.

With Mathematica, I just can create the following

CayleyGraph[PermutationGroup[{Cycles[{{1, 2, 3}}], Cycles[{{1, 5}, {2, 4}}]}], VertexLabels -> Placed["", Center], VertexSize -> 1.5]

It lost some stereoscopic feeling compared to the above one. Since I'm new to Mathematica, I am not quite familiar with this language. Could anyone help me improve it? Thanks in advance.

Answer 1

The simple way:

g = CayleyGraph[
  PermutationGroup[{Cycles[{{1, 2, 3}}], Cycles[{{1, 5}, {2, 4}}]}]]

Graph3D[g, VertexSize -> 0.4, VertexStyle -> Gray]

We can get something that looks more similar to your example by:

• Flattening the colours and disabling 3D shading: use Glow with your preferred colours and set the normal colour to Black.

• Thicken the edges. We need a new EdgeShapeFunction for this because edges are rendered as Tube by default, which does not respond to thickness directives.

• Add "fog" with Raster3D to fade the background.

edges = EdgeList[g] //

     Map[Style[#, Black, 
        Glow@First@PropertyValue[{g, #}, EdgeStyle]] &] //

    ReplaceAll[
     e : DirectedEdge[args___] /; EdgeQ[g, Reverse[e]] :> 
      Sort@UndirectedEdge[args]
     ] //
   DeleteDuplicatesBy[First];

vertices = VertexList[g];

g3d = Graph3D[vertices, edges,
  VertexStyle -> Directive[Black, Glow@GrayLevel[2/3]],
  VertexSize -> 1/2,
  EdgeShapeFunction -> (Tube[Line[#1], 0.05] &)
  ]

Show[g3d,
 Graphics3D[
  Raster3D[
   ConstantArray[.05, {10, 10, 10}], {Scaled[{0, 0, 0}], 
    Scaled[{1, 1, 1}]}, ColorFunction -> Opacity]
  ]
 ]

Here's another one with higher resolution shading:

Show[g3d,
 Graphics3D[
  Raster3D[
   ConstantArray[.02, 50 {1, 1, 1}], {Scaled[{0, 0, 0}], 
    Scaled[{1, 1, 1}]}, ColorFunction -> Opacity]
  ]
 ]

Warning: For some reason, increasing the Raster3D size from 50 to 51 disables the fog shading on my machine (M11.3, macOS 10.14.3).

---

At first I tried to create the corresponding polyhedron and set it to transparent white to fade the rear objects equally. The problem is that parts of them are outside the polyhedron.

It could be done like this with IGraph/M:

Needs["IGraphM`"]

Show[
 g3d,
 Graphics3D[
  GraphicsComplex[
   GraphEmbedding[g3d], {Opacity[0.7], Black, Glow[White], 
    Polygon[IGFaces@UndirectedGraph[g3d]]}]
  ]
 ]