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.
$\begingroup$
$\endgroup$
-
$\begingroup$ I urge you to include some demonstration of your efforts on this problem. The community generally reacts negatively to questions that do not demonstrate effort by the author. $\endgroup$ – Mr.Wizard Mar 23 '15 at 7:27
-
$\begingroup$ Looking at this might help. $\endgroup$ – TransferOrbit Mar 23 '15 at 8:12
$\begingroup$
$\endgroup$
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
]
answered Mar 23 '15 at 8:36
$\begingroup$
$\endgroup$
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.
answered Jul 27 '16 at 16:26
