19
$\begingroup$

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

enter image description here

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]

enter image description here

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.

$\endgroup$
4
  • $\begingroup$ You may try Graph3D to generate 3D-graphs. You can obtain a fog effect by overlaying the resulting graph with a semi-transparent Image3D. See also here. $\endgroup$ Commented Mar 4, 2019 at 9:17
  • 1
    $\begingroup$ Something to start with Graph3D@CayleyGraph[ ..., VertexSize -> .5] $\endgroup$
    – Kuba
    Commented Mar 4, 2019 at 10:06
  • $\begingroup$ Thank you! @HenrikSchumacher $\endgroup$
    – user450201
    Commented Mar 4, 2019 at 10:31
  • $\begingroup$ It works! Thanks!@Kuba $\endgroup$
    – user450201
    Commented Mar 4, 2019 at 10:31

1 Answer 1

21
$\begingroup$

The simple way:

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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

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]]}]
  ]
 ]

enter image description here

$\endgroup$
6
  • $\begingroup$ Nice work! Thanks a lot! $\endgroup$
    – user450201
    Commented Mar 4, 2019 at 10:34
  • $\begingroup$ The missing piece is just the black silhouettes around the circles and the red arrows. $\endgroup$ Commented Mar 4, 2019 at 12:23
  • $\begingroup$ @NaturalNumberGuy I am not sure if that's possible with Graphics3D. Maybe with some image processing trickery. $\endgroup$
    – Szabolcs
    Commented Mar 4, 2019 at 12:45
  • 1
    $\begingroup$ @NaturalNumberGuy Maybe something like this i.sstatic.net/rCpBW.png Random-colour features, rasterize, edge-detect, dilate, overlay the edges on original image, downscale for smooth appearance. $\endgroup$
    – Szabolcs
    Commented Mar 4, 2019 at 12:53
  • 1
    $\begingroup$ We can attempt the same for just the nodes, but I don't like the result: i.sstatic.net/AZxRx.png $\endgroup$
    – Szabolcs
    Commented Mar 4, 2019 at 12:55

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.