How to build an inscribed circle in a triangle on a sphere?

Question

I want to build an inscribed circle into a triangle on a sphere. To do this, I first build its center - the intersection point of the bisectors. But there were problems with finding it. I build the intersection point of the bisectors in the plane of the triangle, and then I look for the corresponding point on the sphere, but judging by the graphical results, this is the wrong way.

sp[u_, v_] := {Sin[u] Cos[v], Sin[u] Sin[v], Cos[u]};
ark[{r1_, r2_}, nt_] := Table[
                        RotationTransform[ t VectorAngle[r1, r2], Cross[r1, r2]][r1],
                        {t, 0, 1, 1/nt}
                    ]

        A = sp[u1, v1];
        B = sp[u2, v2];
        C1 = sp[u3, v3];
        o = {0, 0, 0};
        a = Norm[B - C1];
        b = Norm[C1 - A];
        c = Norm[A - B];
        (* compute intersection point of the bisectors in the plane of the triangle *)
        B0 = (a*A + b*B + c*C1)/(a + b + c);
        B0 = B0/Norm[B0];
 (* compute bisectors *)
 aa = B + c/(c + b)*(C1 - B);
 bb = C1 + a/(c + a)*(A - C1);
 cc = A + b/(b + a)*(B - A);
 aa = aa/Norm[aa];
 bb = bb/Norm[bb];
 cc = cc/Norm[cc];

My questions:

1. How to find the center of an inscribed circle?
2. How to find the bases of bisectors on the sides of a triangle?
3. How to construct the circle itself?

Answer 1

Here is a picture of what I think you're trying to find:

It's a bit of a journey to get there, here's what I did...

Starting with some vertices for our triangle, we find the insphere using these vertices along with the center of the sphere.

SeedRandom[3];
vertices = RandomPoint[Sphere[], 3];
insphere = Insphere[Append[vertices, {0, 0, 0}]];

Let's assign some useful variables.

insphereCenter = insphere[[1]];
insphereRadius = insphere[[2]];
insphereCenterOffset = Norm[insphereCenter];

Thinking ahead, we want some sort of circular indicator at the surface. I'm not going to use a circle, but a cone. This is just for visualization purposes. The cone's side will be tangent to the sphere, so it will just cover the bit of the sphere inside our target circle. The cone at the surface is similar to the cone formed by the center of our insphere and the points of the insphere tangent to the planes that define the sides (great arcs) of the triangle. So, we need to find the original cone and calculate a scaling factor.

inconeHeight = insphereRadius*insphereRadius/insphereCenterOffset;
inconeRadius = Sqrt[insphereRadius^2 - inconeHeight^2];
surfaceScale = 1/Sqrt[Norm[insphereCenter]^2 - insphere[[2]]^2];

This is all just a bit of geometry, mostly Pythagoras.

Now we need to scale and relocate this cone. I started with a simple, axes-aligned cone at the origin and applied a sequence of transforms. First, translate it up to the same height as our insphere, then scale it (which also brings it up to surface level), then rotate it into position.

surfaceIncone = 
  (RotationTransform[{{0, 0, 1}, insphereCenter}]@*
   ScalingTransform[surfaceScale*{1, 1, 1}]@*
   TranslationTransform[{0, 0, insphereCenterOffset - inconeHeight}])[
     Cone[{{0, 0, 0}, {0, 0, inconeHeight}}, inconeRadius]];

Finally, here's how I generated the image above:

Graphics3D[
  {Green, Ball[{0, 0, 0}, .05], 
   Red, Ball[#, .05] & /@ vertices, 
   GrayLevel[.3], surfaceIncone, 
   Blue, Opacity[.4], InfinitePlane[{0, 0, 0}, Take[vertices, 2]], 
   InfinitePlane[{0, 0, 0}, Take[vertices, -2]], 
   InfinitePlane[{0, 0, 0}, Drop[vertices, {2}]], Opacity[.5], 
   Green, Sphere[]}]

There is no error detection here, so there are edge cases that won't produce correct results.

Answer 2

For completeness, I'm going to provide functions for generating the circumcircle and incircle of a spherical triangle:

sphericalCircumcircle[pts_] := Module[{cen, cosr, nrm},
         cen = Total[Cross @@@ Partition[pts, 2, 1, 1]];
         nrm = Norm[cen];
         cosr = Det[pts]/nrm; cen /= nrm;
         BSplineCurve[Composition[TranslationTransform[cen cosr], 
                                  RotationTransform[{{0, 0, 1}, cen}]][
                                  Sqrt[(1 - cosr) (1 + cosr)]
                                  {{1, 0, 0}, {1, 1, 0}, {-1, 1, 0}, {-1, 0, 0},
                                   {-1, -1, 0}, {1, -1, 0}, {1, 0, 0}}], 
                      SplineDegree -> 2, 
                      SplineKnots -> {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1}, 
                      SplineWeights -> {1, 1/2, 1/2, 1, 1/2, 1/2, 1}]]

sphericalIncircle[pts_] := Module[{cen, sinr, nrm},
         cen = RotateLeft[Map[Norm, Cross @@@ Partition[pts, 2, 1, 1]]] . pts;
         nrm = Norm[cen];
         sinr = Det[pts]/nrm; cen /= nrm;
         BSplineCurve[Composition[TranslationTransform[cen Sqrt[(1 - sinr) (1 + sinr)]],
                                  RotationTransform[{{0, 0, 1}, cen}]][sinr
                                  {{1, 0, 0}, {1, 1, 0}, {-1, 1, 0}, {-1, 0, 0},
                                   {-1, -1, 0}, {1, -1, 0}, {1, 0, 0}}],
                      SplineDegree -> 2, 
                      SplineKnots -> {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1}, 
                      SplineWeights -> {1, 1/2, 1/2, 1, 1/2, 1/2, 1}]]

Expressions for the appropriate radii and centers were derived through standard spherical trigonometry. Both of these functions use the NURBS representation of a circle (see e.g. Piegl and Tiller), and both assume that the spherical triangle is determined by three unit vectors, corresponding to a spherical triangle embedded in a unit sphere centered at the origin. (You should rescale and translate appropriately for spherical triangles on spheres with different centers or radii.)

As a concrete demonstration, generate a random spherical triangle:

BlockRandom[SeedRandom[1337, Method -> "MersenneTwister"]; (* for reproducibility *)
            tri = RandomPoint[Sphere[], 3];]

Visualize the triangle and its circumcircle and incircle:

(* http://mathematica.stackexchange.com/a/10994 *)
arc[center_?VectorQ, {start_?VectorQ, end_?VectorQ}] := Module[{ang, co, r},
    ang = VectorAngle[start - center, end - center];
    co = Cos[ang/2]; r = EuclideanDistance[center, start];
    BSplineCurve[{start, center + r/co Normalize[(start + end)/2 - center], end}, 
                 SplineDegree -> 2, SplineKnots -> {0, 0, 0, 1, 1, 1},
                 SplineWeights -> {1, co, 1}]]

Legended[Graphics3D[{{Opacity[0.6], Sphere[]},
                     {Directive[Red, AbsolutePointSize[6]], Point[tri]}, 
                     {Directive[Blue, AbsoluteThickness[3]], 
                      arc[{0, 0, 0}, #] & /@ Partition[tri, 2, 1, 1]},
                     {AbsoluteThickness[2],
                      {ColorData[97, 3], sphericalCircumcircle[tri]}, 
                      {ColorData[97, 4], sphericalIncircle[tri]}}},
                    Boxed -> False, ViewPoint -> {-2.4, 1.3, -2.}], 
         LineLegend[{Directive[AbsoluteThickness[2], ColorData[97, 3]], 
                     Directive[AbsoluteThickness[2], ColorData[97, 4]]},
                    {"spherical circumcircle", "spherical incircle"}]]

Answer 3

I understand that you want to map the picture of a triangle with inscribed circle onto a sphere.

As there is a large distortion at the poles, I pad the image with white to make the image appear in the "temperate" zone of the sphere.

pts = {{-1, -1}, {0, 1}, {1, -1}};
gr = Graphics[{Circle[TriangleCenter[pts, "Incenter"], 
    TriangleMeasurement[pts, "Inradius"]], 
   Line[{{pts[[1]], pts[[2]]}, {pts[[2]], pts[[3]]}, {pts[[3]], 
      pts[[1]]}}], Red, PointSize[0.1], Point[pts[[1]]], Blue, 
   Point[pts[[2]]], Green, Point[pts[[3]]]}] 
{width, height} = ImageMeasurements[Image@gr, "Dimensions"][[;; 2]];
gr = ImagePad[gr, {3 { width, width}, {height, height}}, White];
SphericalPlot3D[1, {u, 0, Pi}, {v, 0,  2 Pi}, 
 TextureCoordinateFunction -> ({#5, 1 - #4} &), 
 PlotStyle -> Texture[gr], ViewPoint -> Left]

Note that there is a small error at the bottom of the circle. I do not know what this is, but I think this is a bug.