2
$\begingroup$

How to draw four spheres of equal radius that are tangent to each other pairwise, and an additional central sphere that is tangent to all four spheres?

sphere = Sphere[{0, 0, 0}, 1];
Graphics3D[{sphere}]
Graphics3D[{sphere}, Boxed -> False, Lighting -> "Neutral", 
 Background -> Black]

How to draw four spheres of equal radius that are tangent to each other pairwise, and an additional central sphere that is tangent to all four spheres?

Furthermore, how to identify the center of each sphere and connect the centers.

Update:

There should be two spheres tangent to the original four spheres: one case is where a sphere is externally tangent to the known spheres, and the second case is where the four spheres are internally tangent to the sphere.And how can this large sphere be drawn?

If the radii of the four spheres are known but unequal, how can the four externally tangent spheres and the two spheres tangent to them be drawn?

$\endgroup$

2 Answers 2

8
$\begingroup$
$Version

(* "14.0.0 for Mac OS X ARM (64-bit) (December 13, 2023)" *)

Clear["Global`*"]

centers = PolyhedronCoordinates[Tetrahedron[]];

center = Mean[centers]

(* {0, 0, 0} *)

largeSpheres = Sphere[#, 1/2] & /@ centers;

r = RegionDistance[largeSpheres[[1]], center]

(* 1/4 (-2 + Sqrt[6]) *)

Graphics3D[{Line /@ 
   Subsets[Flatten[{centers, {center}}, 1], {2}], {Opacity[0.5], 
   largeSpheres},
  {Opacity[0.75], Sphere[center, r]}}]

enter image description here

$\endgroup$
3
  • $\begingroup$ If the four spheres have different radii, and only the radii of the four spheres are known, how can such a diagram be drawn? $\endgroup$
    – csn899
    Commented Apr 11 at 7:49
  • $\begingroup$ There is also a large sphere tangent to the four smaller spheres, which are internally tangent to this large sphere; how can this large sphere be drawn? $\endgroup$
    – csn899
    Commented Apr 11 at 7:57
  • 1
    $\begingroup$ The outer sphere to the original question is trivially just Sphere[center, 1 + r]. The other modification is a new question. Post it showing what you have tried. This is not a free coding service. $\endgroup$
    – Bob Hanlon
    Commented Apr 11 at 14:49
1
$\begingroup$
$Version

(* "14.0.0 for Mac OS X ARM (64-bit) (December 13, 2023)" *)

Clear["Global`*"]

Off[General::munfl]

Manipulate[Module[
  {center, r5, radii, sphere, x, x3, x4, y, y3, y4, z, z4},
  radii = If[rad === "equal", ConstantArray[1, 4],
     If[rad === "unequal", {2, 4, 8, 5},
      RandomReal[{2, 10}, 4]]];
  (* place first sphere at origin *);
  sphere[1] = Sphere[
    center[1] = {0, 0, 0}, radii[[1]]];
  (* place second sphere next to the first *);
  sphere[2] = Sphere[
    center[2] = {radii[[1]] + radii[[2]], 0, 0}, radii[[2]]];
  (* calculate placement for third sphere *);
  {x3, y3} = First[MaximalBy[Last][
      SolveValues[Rationalize[#, 0] &[
        RegionDistance[sphere[#], {x, y, 0}] == radii[[3]] & /@
         {1, 2}], {x, y}, Reals]]] // N;
  sphere[3] = Sphere[
    center[3] = {x3, y3, 0}, radii[[3]]];
  (* calculate placement for fourth sphere *);
  center[4] = {x4, y4, z4} =
    First[MaximalBy[Last][
       SolveValues[Rationalize[#, 0] &[
         RegionDistance[sphere[#], {x, y, z}] == radii[[4]] & /@
          {1, 2, 3}], {x, y, z}, Reals]]] // N;
  sphere[4] = Sphere[center[4], radii[[4]]];
  (* calculate placement for internal sphere *);
  {center[5], {r5}} = Partition[
    ArgMin[{r, Rationalize[#, 0] &[
         RegionDistance[sphere[#], {x, y, z}] == r & /@
          Range[4]], r > 0} // Flatten, {x, y, z, r}] // N,
    UpTo[3]];
  sphere[5] = Sphere[center[5], r5];
  (* display the spheres *);
  Graphics3D[{AbsoluteThickness[1.5],
    If[connect, Line /@ Subsets[center /@ Range[5], {2}],
     Nothing],
    Opacity[opac],
    {ColorData["Rainbow"][(# - 1)/4], sphere[#]} & /@
     Range[5],
    If[Equal @@ radii,
     (* display outer sphere *)
     Sphere[center[5], r5 + 2 radii[[1]]] ,
     Nothing]},
   Boxed -> False]],
 Row[{
   Control[
    {{rad, "equal", "initial four radii"},
     {"equal", "unequal", "random"}}],
   Spacer[20],
   Control[
    {{connect, True, "connect centers"}, {True, False}}]}],
 {{opac, 0.5, "opacity"}, 0, 1, 0.05, Appearance -> "Labeled"},
 SynchronousUpdating -> False,
 TrackedSymbols :> {rad, connect, opac, Sphere}]

enter image description here

$\endgroup$

Your Answer

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

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