I found this image on the web, and I want to know how to draw it with software.
I tried to search, and found this.
I have learned a mapping in the plane.
Mathematica Stack Exchange is a question and answer site for users of Wolfram Mathematica. It only takes a minute to sign up.
Sign up to join this communityI found this image on the web, and I want to know how to draw it with software.
I tried to search, and found this.
I have learned a mapping in the plane.
Since you are a new member I decided to help.
I'll leave it to you to add the joining lines and colors. Look at Tube
for the lines. Also my use of Text
for the numbers means that they do not scale with distance and they are not occluded by the balls.
pyr = NestList[ListCorrelate[{{0, 1}, {1, 1}} , #, {-1, 1}, 0] &, {{1}}, 3];
f1[{z_, y_, x_}] := {(x - z/2 + y/2), Sin[60 °] (y - z/3), -z Sin[60 °]}
f2[0, _] := Sequence[]
f2[n_, coor_] := {Sphere[#, 1/4], Text[Style[n, 18], #]} & @ f1[coor]
Graphics3D[
MapIndexed[f2, pyr, {3}],
Axes -> True
]
I've decided to be ornery and render the trinomial tetrahedron upside-down for this answer.
segmentList[lst_List, prts_] /; VectorQ[prts, IntegerQ] && Total[prts] == Length[lst] :=
With[{acc = Accumulate[prts]},
Inner[Take[lst, {#1, #2}] &, Prepend[Most[acc] + 1, 1], acc, List]]
With[{n = 4},
Graphics3D[{Text[Style[#1, Bold, Medium], #2], Sphere[#2, 1/8]} & @@@
Flatten[{Table[segmentList[Multinomial @@@ FrobeniusSolve[{1, 1, 1}, k],
Range[k + 1, 1, -1]], {k, 0, n}],
Table[{{1, 1/2, -1/2},
{0, Sqrt[3]/2, -1/(2 Sqrt[3])},
{0, 0, Sqrt[2/3]}}.{i, j, k},
{k, 0, n}, {j, 0, k}, {i, 0, k - j}]},
{{4, 3, 2}, {1}}], Boxed -> False]]
No lines on this one either; I'll let you figure out how to add them.