7
$\begingroup$

I am trying to draw two circle SAB and ABC on this sphere (no need dashed line) enter image description here

I tried

a = {0, 0, 0};
b = {7, 0, 0};
c = {65/14, (15 Sqrt[3])/14, 0};
s = {52/7, 0, (12 Sqrt[3])/7};
Graphics3D[{Opacity[.25], Circumsphere[{a, b, c, s}]}, Boxed -> False]

enter image description here

$\endgroup$
7
$\begingroup$

Circumsphere correctly gave you the sphere that passes through points $A, B, C, S$. To get the circumscribed circles, I suggest using a WFR function Circumcircle3D.

a = {0, 0, 0};
b = {7, 0, 0};
c = {65/14, (15 Sqrt[3])/14, 0};
s = {52/7, 0, (12 Sqrt[3])/7};

(* Generate point labels and markers *)
pts = {{Red, Point[#[[2]]]}, {Text[#[[1]], #[[2]] + {0, 0, .5}]}} & /@
    Transpose[{{"A", "B", "C", "S"}, {a, b, c, s}}];

circumcircle = ResourceFunction["Circumcircle3D"];

Graphics3D[{circumcircle[{a, b, c}], circumcircle[{a, b, s}], 
  PointSize[.02], pts, Opacity[.2], Circumsphere[{a, b, c, s}]}, 
 Boxed -> False]

Mathematica graphics

$\endgroup$
7
$\begingroup$

For the input in OP, we can also use RegionPlot3D with the options MeshFunctions and Mesh:

cs = Circumsphere[{a, b, c, s}];

Show[RegionPlot3D[cs, 
  PlotStyle -> Opacity[.1, LightBlue], 
  MeshFunctions -> {#2 &, #3 &}, 
  Mesh -> {{{0, Directive[Orange, Thick, Opacity[1]]}}, 
      {{0, Directive[Blue, Thick, Opacity[1]]}}}], 
 Graphics3D[MapThread[{Black, PointSize[Large], Point@#2, Text[##, {1, -1}]} &,
   {{"A", "B", "C", "S"}, {a, b, c, s}}]]]

enter image description here

Alternatively, we can get the two circles using RegionIntersection[cs, InfinitePlane[{a, b, c}] and RegionIntersection[cs, InfinitePlane[{a, b, s}]:

{c1, c2} = MeshPrimitives[DiscretizeRegion @
  RegionIntersection[cs, InfinitePlane[{a, b, #}]], 1] & /@ {c, s};

Graphics3D[{Opacity[.25], cs, 
  Opacity[1], Thick, Blue, c1, Orange, c2,
  Black, PointSize[Large], Point @ {a, b, c, s},
  MapThread[Text[##, {1, -1}] &, {{"A", "B", "C", "S"}, {a, b, c, s}}]}]

enter image description here

$\endgroup$
4
$\begingroup$

To draw the dashed line automatic, we use the method come from https://mathematica.stackexchange.com/a/238191/72111

a = {0, 0, 0};
b = {7, 0, 0};
c = {65/14, (15 Sqrt[3])/14, 0};
s = {52/7, 0, (12 Sqrt[3])/7};
ball = Circumsphere[{a, b, c, s}];
center = RegionCentroid[ball];
reg1 = RegionIntersection[InfinitePlane[{s, a, b}], 
   Circumsphere[{a, b, c, s}]];
reg2 = RegionIntersection[InfinitePlane[{a, b, c}], 
   Circumsphere[{a, b, c, s}]];
DynamicModule[{v = {2, 1.60, 1.23}},
 Graphics3D[{{{{Opacity[.1], 
      ball}, {ClipPlanes -> Dynamic@Append[v, -v . center], Red, 
      Thick, HighlightMesh[
       DiscretizeRegion[reg1], {Style[0, None], 
        Style[1, Directive[AbsoluteThickness[2], Red]]}], 
      HighlightMesh[
       DiscretizeRegion[reg2], {Style[0, None], 
        Style[1, 
         Directive[AbsoluteThickness[2], Red]]}]}}}, {ClipPlanes -> 
     Dynamic@Append[-v, v . center], 
    HighlightMesh[
     DiscretizeRegion[reg1], {Style[0, None], 
      Style[1, Directive[AbsoluteThickness[2], Dotted, Green]]}], 
    HighlightMesh[
     DiscretizeRegion[reg2], {Style[0, None], 
      Style[1, Directive[AbsoluteThickness[2], Dotted, Green]]}]}, 
   PointSize[.03], Point[{a, b, c, s}]}, ViewPoint -> Dynamic@v, 
  ViewProjection -> "Orthographic", Boxed -> False]]

enter image description here

$\endgroup$
0

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.