# How can I reduce this code to draw a cone and a pyramid

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

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]


How can I reduce those codes?

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]


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]


• 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? Aug 31, 2021 at 4:10
• @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].
– kglr
Aug 31, 2021 at 4:30
• Thank you very much. Aug 31, 2021 at 5:13