6
$\begingroup$

The following code gives me a red sphere, whose surface intersects with a list of some smaller spheres:

list = Tuples[Table[i, {i, -2, 2}], 3];

Graphics3D[{Sphere[{#}, 0.1] & /@ {list}, Style[Sphere[{0, 0, 0}, 3], Opacity[0.4], Red]}]

enter image description here

How can I select only those tuples (smaller spheres) from list that have an intersection with the surface of red sphere?

$\endgroup$
13
$\begingroup$
list = Tuples[Table[i, {i, -2, 2}], 3];
smallspheres = Sphere[#, 1/10] & /@ list;
bigsphere = Sphere[{0, 0, 0}, 3];
MemberBigSphereQ = RegionIntersection[bigsphere, #] =!= EmptyRegion[3] &
surfacespheres = Select[smallspheres, MemberBigSphereQ]

Graphics3D[Join[{bigsphere}, surfacespheres]]

big sphere with small spheres on surface

By packing the spheres more densely it gets more interesting :)

list = Tuples[Table[i, {i, -3, 3, 1/5}], 3];
smallspheres = Sphere[#, 1/10] & /@ list;
surfacespheres = Select[smallspheres, MemberBigSphereQ]
Graphics3D[Join[surfacespheres, {Red, Opacity[0.4], bigsphere}]]

densely packed surface spheres

$\endgroup$
  • $\begingroup$ This solution is mainly for showing how this problem can be solved neatly in an idiomatic way in Mathematica, which i think is good to pick up some high level programming concepts in Mathematica. This makes for good readability and generality and works sufficiently well for a small number of spheres. If performance is of primary concern there are faster methods (see Kubas' and Michael E2's answers for example). $\endgroup$ – Thies Heidecke Sep 14 '17 at 12:56
6
$\begingroup$
Graphics3D[{
    Sphere[Select[list, Abs[Norm[#] - 3] < .1 &], .1]
 ,  Style[Sphere[{0, 0, 0}, 3], Opacity[0.4], Red]
}]
$\endgroup$
5
$\begingroup$

A couple of numerical ways, which should be faster on larger problems:

(* auxiliary function: returns 1/0 if arg is in/out the interval {a, b} *)
intervalMember[a_, b_] := UnitStep[# - a] UnitStep[b - #] &;

Pick[list, Norm /@ N@list // intervalMember[3 - 0.1, 3 + 0.1], 1]

Pick[list, #.# & /@ N@list // intervalMember[(3 - 0.1)^2, (3 + 0.1)^2], 1]

(*  {{-2, -2, -1},..., {2, 2, 1}} -- outputs centers  *)

Yet another way, which is pretty fast (Nearest returns a list sorted by distance):

nf = Nearest[N@list];
Drop[
 nf[{0, 0, 0}, {All, 3 + 0.1}], 
 Length@nf[{0, 0, 0}, {All, 3 - 0.1}]]

For the specific problem in the OP (large integer radius 3 sphere, centers of small spheres on integer grid, only integer coordinates within small spheres are at the centers):

Pick[list, #.# & /@ list, 3^2]
$\endgroup$
3
$\begingroup$

You can use Select together with RegionIntersection to filter out the tuples you want:

list = Tuples[Table[i, {i, -2, 2}], 3];
int = Select[
       list, 
       RegionIntersection[Sphere[#, 0.1], Sphere[{0, 0, 0}, 3]] =!= EmptyRegion[3] &
      ];
Graphics3D[
 {
  Sphere[list, 0.1],
  Blue, Sphere[int, 0.1],
  Opacity@0.4, Red, Sphere[{0, 0, 0}, 3]
 }
]

Mathematica graphics

You can also see from the above how you can simplify your code for the plot a bit:

  • Sphere (and most the other graphics primitives) accept lists of points
  • You can simply put your graphics directives in the first argument of Graphics/Graphics3D, no need for Style (just insert nested lists if you don't want a style to affect what comes later, e.g. {{Red,Sphere[pt1]},Sphere[pt2]} to only make the first sphere red)
$\endgroup$
  • 1
    $\begingroup$ Isn't it what Thies suggested? $\endgroup$ – Kuba Sep 14 '17 at 11:20
  • 1
    $\begingroup$ More or less, yes - I failed to reload the answers before posting. Afterwards, I thought I'd leave this since this gives the list of tuples that generate the spheres, rather than the list of spheres $\endgroup$ – Lukas Lang Sep 14 '17 at 11:22

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.