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$

3 Answers 3

8
$\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

Clear["Global`*"];
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], 
    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 and acknowledge you have read our privacy policy.

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