7
$\begingroup$

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?

enter image description here

Improve this question
$\endgroup$
3
  • $\begingroup$ Note that the image is an artist rendering. I don't think it actually corresponds to a 3D-symmetric spatial configuration. (E.g. the "triangle" in front of the sphere should be bigger than the triangle behind it.) $\endgroup$
    – Michael E2
    Dec 9, 2020 at 18:11
  • $\begingroup$ @MichaelE2 One could interpret it as being the limit as one takes dolly-out, zoom-in to infinity. $\endgroup$
    – Acccumulation
    Dec 10, 2020 at 19:02
  • $\begingroup$ @Acccumulation Almost. The crossings aren't correct, unless the orbits are of different radii, in which case they'd appear to be different sizes. If the thickness was the same throughout the orbit, the thickness wouldn't vary front to back from a perspective infinitely far away. $\endgroup$
    – Michael E2
    Dec 10, 2020 at 19:18

4 Answers 4

Reset to default
10
$\begingroup$

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]

enter image description here

Improve this answer
$\endgroup$
7
  • $\begingroup$ What version of Mathematica you are using? I tried this code with Mathematica 12. The orbits are well but with no sphere. $\endgroup$
    – Saeid
    Dec 9, 2020 at 21:41
  • $\begingroup$ I uploaded the generated output. You see some extra white lines. Also, I see the figure you uploaded has a much better resolution. What kind of format you used? I used png and jpeg. Both did not give me high resolution. $\endgroup$
    – Saeid
    Dec 9, 2020 at 21:59
  • $\begingroup$ I copied the image from Mathematica and pasted it into the stackexchange edit box. $\endgroup$
    – Michael E2
    Dec 9, 2020 at 22:10
  • $\begingroup$ @Saeid Try change rot to something bigger in the 3rd column: rot = { {1, 0, 1/8}, {0, 1, 1/8} }. The problem appears to be that the graphics engine is computing the paths as intersecting. I got such a figure when I had 1/100 in the 3rd column. But you don't want the numbers to get too big or you might distort the figure. Since 1/10 is big enough for me but not for you, I cannot predict how big you have to make it. Play with it. $\endgroup$
    – Michael E2
    Dec 9, 2020 at 22:14
  • $\begingroup$ @Saeid I suppose you could also try different RenderingOptions. $\endgroup$
    – Michael E2
    Dec 9, 2020 at 22:19
9
$\begingroup$

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

enter image description here

Improve this answer
$\endgroup$
1
  • 2
    $\begingroup$ +1 and wishing I could upvote your answer more. Elegance emerging from deep knowledge of the wide range of things Mma can do. I always learn something from your answers. $\endgroup$
    – Jagra
    Dec 9, 2020 at 14:57
6
$\begingroup$

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]

enter image description here

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.

Improve this answer
$\endgroup$
6
$\begingroup$

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]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ You nailed your spheres so well, I borrowed them for my answer. $\endgroup$
    – Jagra
    Dec 9, 2020 at 14:19

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.