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$
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$ – DiSp0sablE_H3r0 May 8 at 10:14

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.