How many triangles are there?

Question

Some time ago I found a puzzle and it stopped my work until I solved it.

One of the possible solutions:

Let us sum upright and upside down triangles whose top lies in the $i$-th row. $$ N=\sum_{i=1}^n N_i^\Delta + N_i^\nabla. $$

For upright triangles we should multiply the number of possible sizes $n-i+1$ by the number of possible horizontal positions $i$ $$ N_i^\Delta = (n-i+1)i. $$ An upside down triangle with size $l$ at $i$-th row have $n-i-l+1$ positions and the size $l$ limited by $\min(i,n-i)$, therefore $$ N_i^\nabla = \sum_{l=1}^{\min(i,n-i)}(n-i-l+1). $$

Finally, we have $$ N=\sum_{i=1}^n\Bigl((n-i+1)i+\sum_{l=1}^{\min(i,n-i)}(n-i-l+1)\Bigr). $$

For $n=28$ rows we get $N=5985$ triangles.

My question is: could you suggest a less trivial solution, which can reveal the power of the different sides of Mathematica? I mean look at this problem from different sides: finding a sequence, image-processing, finding a cycles in a graph and so on.

Answer 1

Edit faster version..

 n = 10
 pt = Flatten[Table[ {(j - i/2 - 1/2), -i (Sqrt[3]/2)}, { i, n}, {j, i} ], 1];
 isegs = GatherBy[ Select[ Subsets[pt, {2}] , 
            IntegerQ[(3/Pi) ArcTan @@ (Subtract @@ #)] & ], Norm[Subtract @@ #] & ];
 all = Flatten[
        Union@Select[Union@Flatten[#, 1] & /@ Subsets[#, {2}] , 
          Length[#] == 3 && 
             Norm[#[[2]] - #[[1]]] ==
             Norm[#[[3]] - #[[1]]] == 
             Norm[#[[2]] - #[[3]]] &] & /@ isegs, 1];

  Export["test.gif", Graphics[{Polygon[# ],Point@pt}] & /@ all ]

 Length@all

235

This returns the 5985 value in reasonable time. Note by the way for a large enough grid you pick up integer length point distances that are not aligned with the grid.

Answer 2

I don't really know what kind of answer you expect here. Your answer is obviously the smart way.

Brute force is always an option though:

trianglePoints[n_] := Module[{p = {}, s = 1},
  Do[Do[AppendTo[p, {a + b/2, Sqrt[0.75] b}], {b, 0, n + 1 - s}]; 
   s++;, {a, 1, n + 1}]; p]

res = Select[Subsets[trianglePoints[28], {3}], 
   Norm[#[[1]] - #[[2]]] == Norm[#[[1]] - #[[3]]] == Norm[#[[2]] - #[[3]]] &&
     Length@DeleteDuplicates@Flatten@#[[{1, 3}]] == 3 &];
Length@res

5985

By the way, there are many more equilateral triangles to find. Check this example:

res2 = Select[Subsets[trianglePoints[3], {3}], 
   Norm[#[[1]] - #[[2]]] == Norm[#[[1]] - #[[3]]] == 
     Norm[#[[2]] - #[[3]]] &];
Grid[
 Partition[
  Graphics[{GrayLevel[0.5], 
      Triangle[{{1, 0}, {3, 4*Sqrt[0.75]}, {5, 0}}], 
      RGBColor[RandomReal[], RandomReal[], RandomReal[]], 
      Triangle[#]}] & /@ res2
, 4]]

Answer 3

MorphologicalBranchPoints

By "less trivial" I mean everything related to the problem. Let me give an example. One can consider this problem as an image-processing problem and calculate the number of triangles directly from the picture (the cropped one).

thin = Thinning@ColorNegate@Binarize@Import@"https://i.sstatic.net/vhqI9.png"

points = Dilation[#, 1] &@MorphologicalBranchPoints@thin

p = ComponentMeasurements[MorphologicalComponents@points,"Centroid"][[All, 2]];
Graphics@Point[p]

We get nice positions of the corners. Now it remains to find all possible equilateral triangles with one horizontal side. Here 10 is the threshold in pixels

nrst = Nearest[p];

snap = With[{p1 = +##/2 + {0, #2[[1]] - #[[1]]} Sqrt[3]/2}, 
    With[{np = nrst[p1][[1]]}, 
     If[Norm[np - p1] < 10, {np, ##, np}, Unevaluated@Sequence[]]]] &;

triangles = 
  Flatten[{snap @@ #, snap @@ Reverse@##} & /@ 
    Select[Subsets[p, {2}], Abs[#[[1, 2]] - #[[2, 2]]] < 10 &], 1];

Graphics@Line@triangles

Length@triangles

5985