2
$\begingroup$

I should be able to get this from the answer here - but, with apologies, I'm afraid I can't figure it out.

I have a sphere and a plane as follows:

x = InfiniteLine[{{0, 0, 0}, {1, 0, 0}}]; 
y = InfiniteLine[{{0, 0, 0}, {0, 1, 0}}]; 
z = InfiniteLine[{{0, 0, 0}, {0, 0, 1}}]; 
plane = InfinitePlane[{{1/2, 0, 0}, {1/2, 1, 0}, {1/2, 0, 1}}]; 
sphere = Sphere[{5, 0, 0}, 10]; 
sphereOrigin = Point[{5, 0, 0}];

Graphics3D[{{Thick, x}, {Thick, y}, {Thick, z}, {Opacity[0.15], 
   plane}, {Opacity[0.15], sphere}, 
     {PointSize[Large], Red, sphereOrigin}}, Boxed -> False]

What I want is a circle marking the contour where the sphere intersects the plane. I don't want to manually add it, because I may wish to use different spheres and different planes.

My trouble is that, when I try to use ContourPlot3D, my math gets muddled; whereas if I try to use Graphics3D I can't figure out how to generate the contour line.

I realise that this is a more basic example of a question that's already been answered - but that just means that the more sophisticated answer is too complex for me...

enter image description here

Improve this question
$\endgroup$
2
  • $\begingroup$ intersection = DiscretizeRegion[RegionIntersection[sphere, plane]]; then just put intersection in your graphics. It is unfortunate that we are forced to discretize it, that the resulting region is a general BooleanRegion, and that Mathematica doesn't have a 3D ellipse/circle primitive which it can replace it with. $\endgroup$
    – flinty
    Sep 24, 2020 at 12:38
  • $\begingroup$ Hi @flinty. Yours is the simpler solution, and many thanks for it. But since another solution has been posted as an answer, I feel compelled to mark it as correct. $\endgroup$
    – Richard Burke-Ward
    Sep 24, 2020 at 13:53

3 Answers 3

Reset to default
4
$\begingroup$

We use the implicit exprssion of plane. The normal of plane is Cross[b-a,c-a]

({x, y, z} - a).Cross[b - a, c - a]==0

And we also use the implicit expression of sphere,here {5,0,0} is the sphere center and 10 is radius.

Norm[{x, y, z} - {5, 0, 0}] - 10==0

Norm[{x, y, z} - {5, 0, 0}] - 10 as MeshFunction

x = InfiniteLine[{{0, 0, 0}, {1, 0, 0}}];
y = InfiniteLine[{{0, 0, 0}, {0, 1, 0}}];
z = InfiniteLine[{{0, 0, 0}, {0, 0, 1}}];
plane = InfinitePlane[{{1/2, 0, 0}, {1/2, 1, 0}, {1/2, 0, 1}}];


sphere = Sphere[{5, 0, 0}, 10];
sphereOrigin = Point[{5, 0, 0}];

fig = Graphics3D[{{Thick, x}, {Thick, y}, {Thick, z}, {Opacity[0.15], 
     plane}, {Opacity[0.15], sphere}, {PointSize[Large], Red, 
     sphereOrigin}}, Boxed -> False];

{a, b, c} = {{1/2, 0, 0}, {1/2, 1, 0}, {1/2, 0, 1}};
circle3 = 
  ContourPlot3D[({x, y, z} - a).Cross[b - a, c - a] == 0, {x, -15, 
    15}, {y, -15, 15}, {z, -15, 15}, 
   MeshFunctions -> 
    Function[{x, y, z}, Norm[{x, y, z} - {5, 0, 0}] - 10], 
   Mesh -> {{0}}, MeshStyle -> {Thick,Red}, ContourStyle -> None, 
   BoundaryStyle -> None];
Show[fig, circle3]

enter image description here

Improve this answer
$\endgroup$
2
$\begingroup$

Using the Mesh option, as indicated in the link only works fur cuts parallel to a coordinate plane. For arbitray intersections:

You can get the cut of your two regions by: "RegionIntersection[plane, sphere]". However, what you get is not a graphical primitive. So, you can not simply use it in Graphics3D. To turn it into something that Graphics3D can digest, you need to use "DiscretizeRegion" what is not too obvious. Here is your coded with the cut:

x = InfiniteLine[{{0, 0, 0}, {1, 0, 0}}];
y = InfiniteLine[{{0, 0, 0}, {0, 1, 0}}];
z = InfiniteLine[{{0, 0, 0}, {0, 0, 1}}];
plane = InfinitePlane[{{1/2, 0, 0}, {1/2, 1, 0}, {1/2, 0, 1}}];
sphere = Sphere[{5, 0, 0}, 10];
sphereOrigin = Point[{5, 0, 0}];
cut = DiscretizeRegion[RegionIntersection[plane, sphere]];

Graphics3D[{{Thick, x}, {Thick, y}, {Thick, z}, {Opacity[0.15], 
   plane}, {Opacity[0.15], sphere}, {PointSize[Large], Red, cut, 
   sphereOrigin}}, Boxed -> False]

enter image description here

Improve this answer
$\endgroup$
0
$\begingroup$

Since the question has already be answered, let me present a variation of cvgmt's answer which might be more readable:

With[{plane = InfinitePlane[{{1/2, 0, 0}, {1/2, 1, 0}, {1/2, 0, 1}}],
      sphere = Sphere[{5, 0, 0}, 10],
      xAxis = InfiniteLine[{{0, 0, 0}, {1, 0, 0}}],
      yAxis = InfiniteLine[{{0, 0, 0}, {0, 1, 0}}],
      zAxis = InfiniteLine[{{0, 0, 0}, {0, 0, 1}}],
      sphereOrigin = Point[{5, 0, 0}]},
     Show[Graphics3D[{{Thick, xAxis, yAxis, zAxis},
                      {Opacity[0.15], plane, sphere},
                      {Directive[PointSize[Large], Red], sphereOrigin}}], 
          ContourPlot3D[Simplify[{RegionMember[sphere, {x, y, z}], 
                                  RegionMember[plane, {x, y, z}]},
                                 {x, y, z} ∈ Reals] // Evaluate,
                        {x, -5, 15}, {y, -10, 10}, {z, -10, 10}, 
                        BoundaryStyle -> {1 -> None, 2 -> None,
                                          {1, 2} -> {{Red, Tube[0.05]}}}, 
                        Contours -> {0}, ContourStyle -> None, Mesh -> None]]]

figure

This is based on the technique originally presented here.

Improve this answer
$\endgroup$

Your Answer

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

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