Drawing hollow disks in 3D with an sphere in center and small spheres on the rings

Question

I was trying to draw the following logo of an atom using Mathematica, but I could only figure out how to draw intersecting ellipses, not a nice logo like below. Do you have any idea? And is Mathematica a good option for this work or I should look for a drawing sofware?

Answer 1

Bells and whistles. Doesn't replicate the crossings of the orbits in the artwork, but it's more consistent. Colors and lighting are a bit hard to get right.

ClearAll[orbit];
orbit // Options = {ColorFunction -> None};
orbit[OptionsPattern[]] :=
  With[{cf = OptionValue[ColorFunction],
    rot = ( {
       {1, 0, 1/10},
       {0, 1, 1/10}
      } )}, 
   Polygon[CirclePoints[1., 120].DiagonalMatrix[{0.3, 1.}].rot -> 
     CirclePoints[{-0.07, 0.}, 0.82, 
       120].DiagonalMatrix[{0.3, 1.1}].rot, 
    VertexColors -> (cf /. {None | Automatic -> Automatic, 
        f_ :> f /@ (Range[120]/120.)})]
   ];

paths = With[{sph = 0.85 {Cos[-0.85] + 0.05, Sin[-0.85]} {0.3, 1.1}},
  Graphics3D[{
    EdgeForm[{Thickness@Medium, White}]
    , {orbit[ColorFunction ->
       (Blend[{Hue[0.05, 1, 0.8], Darker[Yellow, 0.1]}, 
          Cos[Pi # + Pi/4]^2] &)]}
    , GeometricTransformation[
     {orbit[ColorFunction ->
        (Blend[{Hue[0.55, 0.9, 0.7], Darker[Cyan, 0.1]}, 
           Cos[Pi # + Pi/4]^2] &)]},
     RotationTransform[-2 Pi/3, {0, 0, 1}]
     ]
    , GeometricTransformation[
     {orbit[ColorFunction ->
        (Blend[{Darker[Green, 0.4], Darker[Yellow, 0.2]}, 
           Cos[Pi # + Pi/4]^2] &)]},
     RotationTransform[2 Pi/3, {0, 0, 1}]
     ]
    }, PlotRange -> 1, PlotRangePadding -> Scaled[.05], 
   ViewPoint -> Top, Boxed -> False, Lighting -> "Neutral"]
  ];

spheres = With[{sph = 0.85 {Cos[-0.85] + 0.05, Sin[-0.85]} {0.3, 1.1}},
   Graphics[{
     Inset[
      Graphics3D[{Specularity[White, 5], Black, Sphere[]}, 
       Boxed -> False, Lighting -> {{"Point", White, {0, 0, 3}}}],
      Center, Center, Scaled[0.25]],
     , {
      {EdgeForm[White], White, Disk[sph, 0.08]}, 
      Inset[Graphics3D[{Specularity[White, 5], Hue[0.05, 1, 0.8], 
         Sphere[]}, Boxed -> False, 
        Lighting -> {{"Point", Hue[0.1, 1, 1], {0, 0, 3}}, {"Ambient",
            GrayLevel[0.6]}}],
       sph, Center, Scaled[0.12]]}
     , GeometricTransformation[
      {
       {EdgeForm[White], White, Disk[sph, 0.08]},
       Inset[
        Graphics3D[{Specularity[White, 5], Hue[0.55, 0.9, 0.75],
          Sphere[]}, Boxed -> False,
         Lighting -> {{"Point", Darker[Cyan, 0.2],
            
            RotationTransform[2 Pi/3, {1.3, -2.4, 2}]@{0, 0, 
              3}}, {"Ambient", GrayLevel[0.6]}}],
        sph, Center, Scaled[0.12]]},
      RotationTransform[-2 Pi/3]
      ]
     , GeometricTransformation[
      {
       {EdgeForm[White], White, Disk[sph, 0.08]},
       Inset[
        Graphics3D[{Specularity[White, 5], Darker[Green, 0.3], 
          Sphere[]},
         Boxed -> False,
         Lighting -> {{"Point", Darker[Yellow, 0.3],
            
            RotationTransform[-2 Pi/3, {1.3, -2.4, 2}]@{0, 0, 
              3}}, {"Ambient", GrayLevel[0.6]}}],
        sph, Center, Scaled[0.12]]},
      RotationTransform[2 Pi/3]
      ]
     }, PlotRange -> 1, PlotRangePadding -> Scaled[.05]]
   ];

Show[
 Graphics[Inset[paths, Center, Center, Scaled[1.8]],
  PlotRange -> 1, PlotRangePadding -> Scaled[.05]],
 spheres]

Answer 2

One of many ways to get 3D hollow disks is to use Annulus[] to specify the region in Plot3D:

p3d = Plot3D[{x + y, x/2, -y}, {x, y} ∈ Annulus[{0, 0}, {.9, 1}], 
   Mesh -> None, MaxRecursion -> 5, PlotPoints -> 90,
   BoundaryStyle -> Directive[Thick, Gray], Lighting -> "Neutral", 
   PlotStyle -> {Lighter @ Magenta, Cyan, Lighter @ Green}];

Place the spheres at random points on the centers of the orbit annuli:

boxratios = {1, 1, 3};

SeedRandom[1]
g3d = Graphics3D[{Black, Specularity[White, 10], 
    Scale[Sphere[{0, 0, 0}, .2], 1/boxratios], 
    MapThread[{#, Scale[Sphere[Append[#2 @ #3] @ #3, .12], 1/boxratios]} &, 
     {{Red, Blue, Green}, {Total, First[#]/2 &, -Last[#] &}, 
      RandomPoint[Circle[{0, 0}, .95], 3]}]}];


Show[p3d, g3d , Boxed -> False, BoxRatios -> boxratios, Axes -> False,
 ImageSize -> Large, Lighting -> "Neutral", ViewPoint -> {5/4, -3/4, 3},
 PlotRange -> All, PlotRegion -> {{0, 1}, {-0.2, 1.3}}]

Answer 3

Second thoughts (borrowing some code from How to draw a circle in 3d on a sphere):

circle3D[centre_ : {0, 0, 0}, radius_ : 1, normal_ : {0, 0, 1}, 
  angle_ : {0, 2 Pi}] := 
 Composition[Line, 
   Map[RotationTransform[{{0, 0, 1}, normal}, centre], #] &, 
   Map[Append[#, Last@centre] &, #] &, 
   Append[DeleteDuplicates[Most@#], Last@#] &, Level[#, {-2}] &, 
   MeshPrimitives[#, 1] &, DiscretizeRegion, If][
  First@Differences@angle >= 2 Pi, Circle[Most@centre, radius], 
  Circle[Most@centre, radius, angle]]

  Graphics3D[{
  circle3D[{1, 0, 1}, 2],
  circle3D[{1, 0, 1}, 1.8],
  circle3D[{1, 0, 1}, 2, {1, -1, 1}],
  circle3D[{1, 0, 1}, 1.8, {1, -1, 1}],
  circle3D[{1, 0, 1}, 2, {1, -1, -1}],
  circle3D[{1, 0, 1}, 1.8, {1, -1, -1}],
  {Opacity[0.95], Sphere[{1, 0, 1}, .5]},
  {Blue,Specularity[White, 10], Sphere[{-0.5, -0.56, 2}, .15]},
  {Red,Specularity[White, 10], Sphere[{2.88, 0, 1.01}, .15]},
  {Green,Specularity[White, 10], Sphere[{0, 0.6, -0.6}, .15]}
  },
 Boxed -> False]

More to come, e.g.:

• Better placement of the orbiting spheres (maybe animate the orbits ;-)
• Fill between the concentric circles forming the disks.
• Color variance/gradations of disks.
• Angles of the disks.

Maybe wrap all of this in a Manipulate so one could vary this sort of stuff and get the design you want.

So basically, YES one can do this in Mathematica.

Answer 4

A start:

Graphics3D[
 {Specularity[White, 10], 
  Black, Sphere[],
  Red, Sphere[{1, 1, 1}, .3],
  Blue, Sphere[{-1, -1, 1}, .3],
  Green, Sphere[{-1, 1, 1}, .3]},
 Lighting -> {{"Point", White, {3, 0, 5}}},
 Boxed -> False]