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

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.