¿Cómo trazar un agujero en un agujero en un agujero?

Question

Hay una imagen de este libro.(página 22)

Quiero trazarlo, pero no conozco la ecuación de esta superficie.

Alguien tiene una idea al respecto y cómo trazarlo con Mathematica ?

Answer 1

Pensaba responder a esto en Mathematica.stackexchange pero se migró antes de que terminara :(

Afortunadamente, sigue pidiendo consejos de codificación de Mathematica y, además, mi respuesta contiene algunas fórmulas, por lo que debería estar dentro del tema :)

Imaginé que daría un ejemplo ordenado de las características relacionadas con la región, pero es más rápido escribir los parámetros manualmente que esperar a TransformedRegion con Scaling/RotationTransform para volver.

torus = ImplicitRegion[(Sqrt[x^2 + y^2] - .7)^2 + z^2 < .2^2, {x, y, z}];

tube = ImplicitRegion[x^2 + y^2 < .1 z^2 + .1, {x, y, z}];

smallTube =  ImplicitRegion[
   x^2 + z^2 < .05 (y - 1.2)^2 + .01 && .6 <= y <= 2.5, 
   {x, y, z}
];

RegionPlot3D[
    Fold[
        RegionDifference
      , Ball[{0, 0, 0}, 2]
      , {torus, tube, smallTube
          , TransformedRegion[smallTube, ReflectionTransform[{0, 1, 0}]]
        }
    ]
  , BaseStyle -> Opacity[.5]
  , PlotPoints -> 60
]