Return to Answer

added another version

Source Link

edited Jul 21, 2016 at 1:05

125.4k
11
407
581

Here's a variation using CirclePoints[] to evenly sample the circle:

BlockRandom[SeedRandom["spherical"];
            c1 = RandomReal[1, 3]; c2 = RandomReal[1, 3];
            r2 = RandomReal[3/2]; r1 = RandomReal[3/2];
            d = EuclideanDistance[c1, c2];
            u = (d^2 + r1^2 - r2^2)/(2 d^2); cc = {1 - u, u}.{c1, c2};
            rc = Sqrt[r1^2 - d^2 u^2];
            n = 30;
            Graphics3D[{Opacity[1/2], Sphere[c1, r1], Sphere[c2, r2],
                        {Red, Sphere[AffineTransform[{RotationMatrix[{{0, 0, 1},
                                                      Normalize[c2 - c1]}], cc}][
                                     PadRight[ArrayPad[CirclePoints[rc, n],
                                                       {{0, 1}, {0, 0}}, "Periodic"],
                                              {Automatic, 3}]], 1/100]}}, Boxed -> False]]

crown of spheres

Here's a variation using CirclePoints[] to evenly sample the circle:

BlockRandom[SeedRandom["spherical"];
            c1 = RandomReal[1, 3]; c2 = RandomReal[1, 3];
            r2 = RandomReal[3/2]; r1 = RandomReal[3/2];
            d = EuclideanDistance[c1, c2];
            u = (d^2 + r1^2 - r2^2)/(2 d^2); cc = {1 - u, u}.{c1, c2};
            rc = Sqrt[r1^2 - d^2 u^2];
            n = 30;
            Graphics3D[{Opacity[1/2], Sphere[c1, r1], Sphere[c2, r2],
                        {Red, Sphere[AffineTransform[{RotationMatrix[{{0, 0, 1},
                                                      Normalize[c2 - c1]}], cc}][
                                     PadRight[ArrayPad[CirclePoints[rc, n],
                                                       {{0, 1}, {0, 0}}, "Periodic"],
                                              {Automatic, 3}]], 1/100]}}, Boxed -> False]]

crown of spheres

Source Link

created Jul 20, 2016 at 17:42

J. M.'s missing motivation ♦

125.4k
11
407
581

Using the results from this MathWorld page:

BlockRandom[SeedRandom["spherical"];
            c1 = RandomReal[1, 3]; c2 = RandomReal[1, 3];
            r2 = RandomReal[3/2]; r1 = RandomReal[3/2];
            d = EuclideanDistance[c1, c2];
            u = (d^2 + r1^2 - r2^2)/(2 d^2); cc = {1 - u, u}.{c1, c2}; 
            rc = Sqrt[r1^2 - d^2 u^2];
            Graphics3D[{Opacity[1/2], Sphere[c1, r1], Sphere[c2, r2],
                        {Red, Tube[BSplineCurve[
                                   AffineTransform[{RotationMatrix[{{0, 0, 1},
                                                    Normalize[c2 - c1]}], cc}][
                                   rc PadRight[{{1, 0}, {1, 1}, {0, 1}, {-1, 1},
                                                {-1, 0}, {-1, -1}, {0, -1}, {1, -1},
                                                {1, 0}}, {Automatic, 3}]], 
                                   SplineClosed -> True, SplineDegree -> 2, 
                                   SplineKnots -> {0, 0, 0, 1/4, 1/4, 1/2,
                                                   1/2, 3/4, 3/4, 1, 1, 1},
                                   SplineWeights -> {1, 1/Sqrt[2], 1, 1/Sqrt[2], 1,
                                                     1/Sqrt[2], 1, 1/Sqrt[2], 1}]]}},
                       Boxed -> False]]

two intersecting spheres