11
$\begingroup$

I want to put edges on this Nicomachus's Triangle

r = 7;
t = Table[2^(n - k) 3^k, {n, 0, r}, {k, 0, n}];
ColumnForm[t, Center]

Is there an easy way to do this?

Using Mr. Wizard's method

triangleForm[t : {_List ..} /; Depth@t == 3] :=
 Show[Graphics[{
    Red,
    (Line /@ Join[#, Riffle @@@ Partition[#, 2, 1]]) &@
      Table[{(1 - i + 2 j - r)/2, i - r - 1}, {i, 0, r}, {j, i, r}],
    MapIndexed[Text[Panel[#, FrameMargins -> 0], {#2 - #/2, -#} & @@ #2] &,     t, {2}]
   }],
  TextStyle -> FontSize -> 18
 ]

triangleForm[t]

NicomachusTriangle

https://math.stackexchange.com/questions/150259/question-about-the-collatz-conjecture-nicomachuss-triangle-and-more

$\endgroup$

3 Answers 3

9
$\begingroup$

Something like this?

triangleForm[t : {_List ..} /; Depth@t == 3] :=
 Show[Graphics[{
    MapIndexed[Text[#, {#2 - #/2, -#} & @@ #2] &, t, {2}],
    Red,
    Line[{{1/2, -1}, {1 - #/2, -#}, {#/2, -#}, {1/2, -1}}] & @ Length[t]
   }],
  TextStyle -> FontSize -> 18]

triangleForm[t]

Mathematica graphics

Or probably more like:

triangleForm[t : {_List ..} /; Depth@t == 3] :=
 Show[Graphics[{
    MapIndexed[Text[#, {#2 - #/2, -#} & @@ #2] &, t, {2}],
    Red,
    Line[{{1/2, 0}, {-#/2, -# - 1/2}, {1 + #/2, -# - 1/2}, {1/2, 0}}] & @ Length[t]
   }],
  TextStyle -> FontSize -> 18]

triangleForm[t]

Mathematica graphics


With automatic image size:

r = 9;
t = Table[2^(n - k) 3^k, {n, 0, r}, {k, 0, n}];

triangleForm[t : {_List ..} /; Depth@t == 3] :=
 Show[Graphics[{
    MapIndexed[Text[#, {#2 - #/2, -#} & @@ #2] &, t, {2}],
    Red,
    Line[{{1/2, 0}, {-#/2, -# - 1/2}, {1 + #/2, -# - 1/2}, {1/2, 0}}] & @ Length[t]
   }],
  TextStyle -> FontSize -> 16,
  ImageSize -> (Length@t + 1) * First@Rasterize[Style[t[[-1, -1]], 16], "RasterSize"]
 ]

triangleForm[t]

Mathematica graphics


Another variation following a comment below:

r = 8;
t = Table[2^(n - k) 3^k, {n, 0, r}, {k, 0, n}];

triangleForm[t : {_List ..} /; Depth@t == 3] :=
 Show[Graphics[{
    Red,
    (Line /@ Join[#, Riffle @@@ Partition[#, 2, 1]]) &@
      Table[{(1 - i + 2 j - r)/2, i - r - 1}, {i, 0, r}, {j, i, r}],
    MapIndexed[Text[Panel[#, FrameMargins -> 0], {#2 - #/2, -#} & @@ #2] &, t, {2}]
   }],
  TextStyle -> FontSize -> 18
 ]

triangleForm[t]

Mathematica graphics

$\endgroup$
9
  • $\begingroup$ @belisarius are you making the graphic large enough for all the numbers? $\endgroup$
    – Mr.Wizard
    Commented May 27, 2012 at 1:49
  • $\begingroup$ Can you pre-calculate the image size? :D $\endgroup$ Commented May 27, 2012 at 1:52
  • $\begingroup$ @belisarius I suppose so; let me try $\endgroup$
    – Mr.Wizard
    Commented May 27, 2012 at 1:52
  • $\begingroup$ @Mr.Wizard, like the first one, but with all the inner triangles shown also. $\endgroup$ Commented May 27, 2012 at 2:09
  • $\begingroup$ @Fred okay, give me a minute. :-) $\endgroup$
    – Mr.Wizard
    Commented May 27, 2012 at 2:18
8
$\begingroup$

Here's an alternative way to create the latter picture in Mr.Wizard's answer using Graph:

elem[n_, k_] := 2^(n - k) 3^k

Block[{e, r},
 r = 7;
 vertices = Flatten[Table[e[n, k], {n, 0, r}, {k, 0, n}]];
 edges = Flatten[{
     Table[e[n, k] \[UndirectedEdge] e[n + 1, k], {n, 0, r - 1}, {k, 0, n}],
     Table[e[n, k] \[UndirectedEdge] e[n + 1, k + 1], {n, 0, r - 1}, {k, 0, n}],
     Table[e[n, k] \[UndirectedEdge] e[n, k + 1], {n, 1, r}, {k, 0, n - 1}]}];
 coords = Flatten[Table[{-n/2 + k, r - n}, {n, 0, r}, {k, 0, n}], 1];

 Graph[vertices, edges, VertexCoordinates -> coords,
  EdgeStyle -> Directive[Thick, Red],
  VertexShapeFunction -> ({Black, 
      Inset[Framed[Style[#2 /. e -> elem, 12, FontFamily -> "Helvetica"], 
        Background -> White, RoundingRadius -> 3], #1]} &)]
]

Mathematica graphics

$\endgroup$
1
  • $\begingroup$ That is what I was trying to do before I gave up and asked the question. I've added it to my .nb $\endgroup$ Commented May 27, 2012 at 10:30
3
$\begingroup$

For $r \in \{2 \ldots 10\}$, you can use GraphData[{"TriangularGrid", r}] to get a graph with the desired structure:

GraphData["TriangularG*"]

{{"TriangularGrid", 2}, {"TriangularGrid", 3}, {"TriangularGrid", 4}, {"TriangularGrid", 5}, {"TriangularGrid", 6}, {"TriangularGrid", 7}, {"TriangularGrid", 8}, {"TriangularGrid", 9}, {"TriangularGrid", 10}}

For example,

GraphData[{"TriangularGrid", 4}]

enter image description here

We can use it to make a function to add labels and other options:

ClearAll[tF, labelingF, tGG]

tF = Flatten@Table[2^(n - k) 3^k, {n, 0, #}, {k, 0, n}] &;

labelingF = AssociationThread[Range @ Length @ #, #] & @ tF[#] &;

tGG = Module[{tg = GraphData[{"TriangularGrid", #}], lbl = labelingF[#]}, 
    SetProperty[tg,
       {VertexShapeFunction -> (Text[Framed[Style[lbl @ #2, Black], 
          RoundingRadius -> 5, FrameStyle -> Gray, Background -> White], #] &), ##2}]] &;

Examples:

Row[tGG[#, EdgeStyle -> Red, ImageSize -> 300] & /@ {3, 5, 7}, Spacer[10]]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.