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

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?

$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]}}]  • If the four spheres have different radii, and only the radii of the four spheres are known, how can such a diagram be drawn? Commented Apr 11 at 7:49 • 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? Commented Apr 11 at 7:57 • 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. Commented Apr 11 at 14:49 $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},
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[
(* 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;
(* 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],
(* display outer sphere *)
Sphere[center[5], r5 + 2 radii[[1]]] ,
Nothing]},
Boxed -> False]],
Row[{
Control[