9
$\begingroup$

There is an image from this book.(page 22)

I want to plot it, but I don't know equation of this surface.

enter image description here

Anyone have an idea about it and how to plot it with Mathematica?

$\endgroup$
5
  • 7
    $\begingroup$ while interesting, I feel like this is more of a math question on how to parametrize that surface $\endgroup$
    – glS
    Mar 1, 2017 at 14:45
  • $\begingroup$ You might look at the parametric plot of a Klein bottle, it has similar properties (not the same though). See this link. $\endgroup$
    – Phil Neumiller
    Mar 1, 2017 at 15:19
  • $\begingroup$ You could get a shape of the right topology at least by using RegionUnion, RegionDifference etc. on a Sphere, some Cylinder's, and a torus (as an ImplicitRegion perhaps). $\endgroup$
    – user856
    Mar 1, 2017 at 15:20
  • $\begingroup$ I could not find anything relevant but may be these links are useful. kleinbottle.com/gallery/Hole-through-a-Hole-in-a-Hole kleinbottle.com/gallery/Spivak_Hole_Pix youtube.com/watch?v=k8Rxep2Mkp8 Especially the video. $\endgroup$
    – Dimitris
    Mar 1, 2017 at 15:54
  • 1
    $\begingroup$ I admire everyone's (well, everyone else's) restraint in not mentioning the relevant meme here. $\endgroup$
    – anomaly
    Oct 31, 2017 at 5:26

1 Answer 1

Reset to default
8
$\begingroup$

I was planning to answer this on Mathematica.stackexchange but it was migrated before I finished :(

Fortunately it still asks for Mathematica coding tips and additionally my answer contains some formulas so it should be on topic :)

I imagined I will give a neat example of region related features but it is quicker to write parameters manually than to wait for TransformedRegion with Scaling/RotationTransform to return.

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
]

enter image description here

$\endgroup$
3
  • $\begingroup$ Very nice! But I think it deserves also to be in Mathematica.stackexchange:-)! $\endgroup$
    – Dimitris
    Mar 1, 2017 at 20:34
  • 2
    $\begingroup$ I cast the final vote on this migration so blame me. Sorry about that. But if it made you get your feet wet over here on Mathematics maybe it's not a bad thing; this community can only be enriched by your presence. $\endgroup$
    – Mr.Wizard
    Mar 1, 2017 at 22:55
  • $\begingroup$ @Mr.Wizard so much sugar :) But thanks, and you are right, it helped me to get wet which was something I was hesitant about :) $\endgroup$
    – Kuba
    Mar 2, 2017 at 8:31

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .