2
$\begingroup$

I am trying to draw this question by Mathematica. I tried

Clear[a, b, c, d];
d = {0, 0, 0};
b = {3, 0, 0};
c = {0, 3, 0};
a = {0, 0, 3};
g = (a + b + c)/3;
r = EuclideanDistance[g, a];
Graphics3D[{Opacity[0.5], Cone[{g, d}, r], Black, 
  Text[Style["D", Italic, 14, FontFamily -> "Times"], {0, 0, -0.2}],
  Text[Style["A", Italic, 14, FontFamily -> "Times"], {0, 0, 3.1}],
  Text[Style["B", Italic, 14, FontFamily -> "Times"], {3.1, 0, 0}],
  Text[Style["C", Italic, 14, FontFamily -> "Times"], {0, 3.1, 0}],
  Text[Style["G", Italic, 14, FontFamily -> "Times"], {1, 1, 0.8}],
  Thick, Blue, Line[{{a, b, c, a}, {d, a, b, d}}],
  Dashed, Red, Line[{{d, g}, {d, c}}],
  Blue, {PointSize[0.015], Point[{a, b, c, d, g}]}}, Boxed -> False]

I got

enter image description here

And tried

Clear[a, b, c, d];
d = {0, 0, 0};
b = {3, 0, 0};
c = {0, 3, 0};
a = {0, 0, 3};
g = (a + b + c)/3;
r = EuclideanDistance[g, a];
\[ScriptCapitalR] = Tetrahedron[{a, b, c, d}];
Graphics3D[{Opacity[0.5], Cone[{g, d}, r], Black,
  EdgeForm[{Blue}], FaceForm[{Pink, Opacity[0.2]}], \[ScriptCapitalR],
  Text[Style["D", Italic, 14, FontFamily -> "Times"], {0, 0, -0.2}],
  Text[Style["A", Italic, 14, FontFamily -> "Times"], {0, 0, 3.1}],
  Text[Style["B", Italic, 14, FontFamily -> "Times"], {3.1, 0, 0}],
  Text[Style["C", Italic, 14, FontFamily -> "Times"], {0, 3.2, 0}],
  Text[Style["G", Italic, 14, FontFamily -> "Times"], {1, 1, 0.8}],
  Black, {PointSize[0.015], Point[{a, b, c, d, g}]}
  }, Boxed -> False]

enter image description here

How can I reduce those codes?

Improve this question
$\endgroup$

1 Answer 1

Reset to default
8
$\begingroup$ 
labels = Style[#, Italic, 14, FontFamily -> "Times"] & /@ {"A", "B", "C", "D", "G"}

coordinates = {a, b, c, d, g};

cone = Graphics3D[{Opacity @ .5, Cone[{g, d}, Norm[g - a]]}];

We can use MeshRegion and the options MeshCellStyle and MeshCellLabel to style and label the primitives:

tetrahedron = MeshRegion[coordinates, 
  {Tetrahedron @ Range @ 4, Line[{{4, 5}, {4, 3}}]}, 
  MeshCellStyle -> {2 -> FaceForm[],
     0 -> Directive[PointSize[Large], Black],
     {1, _} -> Directive[Blue, Thick],
     {1, 5 | 7} -> Directive[Orange, Thick, Dashed]}, 
  MeshCellLabel -> Table[{0, i} -> labels[[i]], {i, 5}]]; 

Show[cone, tetrahedron, Boxed -> False]

enter image description here

Alternatively,

lines = MeshRegion[coordinates, 
  {Line[Append[{4, 5}] @ Subsets[Range[4], {2}]]}, 
  MeshCellStyle -> {0 -> Directive[PointSize[Large], Black],
     {1, _} -> Directive[Blue, Thick],
     {1, 6 | 7} -> Directive[Orange, Thick, Dashed]}, 
  MeshCellLabel -> Table[{0, i} -> labels[[i]], {i, 5}]]; 

 Show[cone, lines, Boxed -> False]

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ I am sorry, I do not understand the numbers in Line[{{4, 5}, {4, 3}}] or {1, 5 | 7} -> Directive[Orange, Thick, Dashed] Can you explaint them for me? $\endgroup$
    – minhthien_2016
    Aug 31, 2021 at 4:10
  • $\begingroup$ @minhthien_2016, the numbers in Line[{{4, 5}, {4, 3}}] refer to the part indices of coordinates; that is, 4 refers to part 4 of coordinates (i.e.,{0, 0, 0}) and 3 refers to part 3 of coordinates ({0, 3, 0}). The lhs in {1, 5 | 7} -> Directive[Orange, Thick, Dashed] refers to cell indices ( the list {x,y} refers to the mesh primitive with dimension x (0 for points, 1 for lines , 2 for faces) and index y ). That is, the rule {1, 5 | 7} -> Directive[Orange, Thick, Dashed] says style the lines with index 5 or 7 using Directive[Orange, Thick, Dashed]. $\endgroup$
    – kglr
    Aug 31, 2021 at 4:30
  • $\begingroup$ Thank you very much. $\endgroup$
    – minhthien_2016
    Aug 31, 2021 at 5:13

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.