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

$\endgroup$
  • $\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 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 at 13:53
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.

$\endgroup$

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.