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$

migrated from mathematica.stackexchange.com Mar 1 '17 at 17:43

This question came from our site for users of Wolfram Mathematica.

  • 6
    $\begingroup$ while interesting, I feel like this is more of a math question on how to parametrize that surface $\endgroup$ – glS Mar 1 '17 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 '17 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$ – Rahul Mar 1 '17 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 '17 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 '17 at 5:26
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$
  • $\begingroup$ Very nice! But I think it deserves also to be in Mathematica.stackexchange:-)! $\endgroup$ – Dimitris Mar 1 '17 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 '17 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 '17 at 8:31

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.