2
$\begingroup$

It is easy to draw a sphere in Mathematica. The following command does the trick:

 ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], Sin[th]}, {th, -Pi,
   Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, Axes -> None, Boxed -> False]

I am wondering if there is a way to plot a squashed sphere in Mathematica by manipulating the above command; namely a sphere that has two points that shrink like the one that is shown below

enter image description here

You have to imagine that this is a proper sphere with two points that shrink and you can understand that I am not a good painter.

The reason that I am asking how to manipulate the command of the ordinary round sphere, is that the ultimate goal is to create the following image:

enter image description here

The way that I have done it -by following some excellent answers here- is the following:

smallSphere1 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > .8 &)];
smallSphere2 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > .6 &)];
smallSphere3 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > .4 &)];
smallSphere4 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > .2 &)];
smallSphere5 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > .0 &)];
smallSphereng1 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > -.8 &)];
smallSphereneg2 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > -.6 &)];
smallSphereneg3 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > -.4 &)];
smallSphereneg4 = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red], 
   RegionFunction -> (#2 > -.2 &)];
bigSphere = 
  ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], 
    Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, 
   PlotStyle -> {LightGreen}, RegionFunction -> (#2 < 1 &)];
Show[bigSphere, smallSphere1, smallSphere2, smallSphere3, \
smallSphere4, smallSphere5, smallSphereng1, smallSphereneg2, \
smallSphereneg3, smallSphereneg4, PlotRange -> All, Axes -> None, 
 Boxed -> False]
$\endgroup$

1 Answer 1

4
$\begingroup$

Do you mean something like this?

RevolutionPlot3D[{Sin[t], t}, {t, 
  0, π}, {θ, -π, π}, MeshFunctions -> {#3 &}, 
 BoundaryStyle -> None]

enter image description here

$\endgroup$
1
  • $\begingroup$ Yes, thanks for this nice suggestion. I was not aware of the RevolutionPlot3D command $\endgroup$
    – user49048
    May 8, 2021 at 10:14

Your Answer

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