How to count the number of n-gons and line intersections in an image of a complete graph?

Question

I would like to count the number of line intersections and number of n-gons in a complete graph (which forms a regular polygon). The only way I've come up with that would allow me to do both in Mathematica would be to:

1. Produce an image of the graph;
2. Apply some image processing tricks. I'm completely new to the world of image processing though.

Here is an example of a 10-graph:

n = 10;
firstCorners = Table[{Cos[2 Pi i], Sin[2 Pi i]}, {i, 0, 1, 1/n}];
lines = Subsets[firstCorners, {2}];
img = Image[Graphics[{Thick, Line[lines]}, ImageSize -> 350]]

I've got no idea how to proceed from here, everything I've tried has failed.

Answer 1

Here is my humble attempt to solve this problem.

- Counting the intersections:

Basically I'm just taking every points, I create linear functions out of them, and I search where they intersect.

n=10;
firstCorners=N[Table[{Cos[2 Pi i],Sin[2 Pi i]},{i,0,1,1/n}]];
lines=Subsets[firstCorners[[1;;n]],{2}];
slope[points_]:=Subtract@@(Last/@points)/Subtract@@(First/@points)
eq[points_,x_]:=Quiet@Simplify[slope[points]*x+Last@First@points-First@First@points*slope@points]
isInside[{x_,y_}]:=If[x^2+y^2<=1,True,False]
coor[{i_,j_}]:=
  If[Reduce[eq[lines[[i]],x]==eq[lines[[j]],x]&&-1<=x<=1]=!=False,
   With[{c=Reduce[x==Reduce[eq[lines[[i]],x]==eq[lines[[j]],x]&&-1<=x<=1][[2]]&&y==eq[lines[[j]],x]&&-1<=y<=1]},
     If[c=!=False&&isInside[{x,y}/.ToRules@c],{x,y}/.ToRules@c,{0,0}]],{0,0}]
subsets=Subsets[Range@Length@lines,{2}];
vertical=Flatten@Position[eq[lines[[#]],x]&/@Range@Length@lines,Indeterminate];
samePoint=Flatten@Position[lines,{firstCorners[[#]],_}|{_,firstCorners[[#]]},Infinity]&/@Range@(Length@firstCorners-1);
posSamePoint=Flatten@Position[subsets,#]&/@Flatten[Subsets[#,{2}]&/@samePoint,1]/.{}:>Sequence[];
subsets=Delete[subsets,posSamePoint];
subsets=Cases[subsets, Except[{Alternatives @@ vertical, _} | {_, Alternatives @@ vertical}]];
pts=DeleteDuplicates@Cases[coor@#&/@subsets,_List];//AbsoluteTiming
vpts=DeleteDuplicates@Flatten[Select[Table[With[{x=First@First@lines[[#]]},{x,eq[lines[[i]],x]}],{i,Delete[Range@Length@lines,List/@vertical]}],isInside@#&]&/@vertical,1];
allpts=If[OddQ@n,Cases[DeleteDuplicates@Round[Chop@Flatten[{pts,vpts,firstCorners},1],10^-10],Except[{0,0}]],DeleteDuplicates@Round[Chop@Flatten[{pts,vpts,firstCorners},1],10^-10]];
Length@allpts

{0.491546, Null}
171

Graphics[{Thin, Line[lines], Red, [email protected], Point@allpts}, ImageSize -> 350]

So that method works for at least n = 30. Here is the result with n = 20 (n = 30 is quite messy):

{11.589748, Null}
3861

By running this piece of code for n = Range[3, 10] one can easily find that the number of intersections is equal to {3, 5, 10, 19, 42, 57, 135, 171}. Thus, searching for this sequence in Wolfram|Alpha leads to this OEIS sequence with it's associated Mathematica code:

del[m_, n_] := If[Mod[n, m] == 0, 1, 0]; 
numberOfNodes[n_] := 
 If[n < 4, n, 
  n + Binomial[n, 4] + del[2, n] (-5 n^3 + 45 n^2 - 70 n + 24)/24 - 
   del[4, n] (3 n/2) + del[6, n] (-45 n^2 + 262 n)/6 + 
   del[12, n]*42 n + del[18, n]*60 n + del[24, n]*35 n - 
   del[30, n]*38 n - del[42, n]*82 n - del[60, n]*330 n - 
   del[84, n]*144 n - del[90, n]*96 n - del[120, n]*144 n - 
   del[210, n]*96 n]; 
numberOfNodes[#] & /@ Range[1, 20]

{1, 2, 3, 5, 10, 19, 42, 57, 135, 171, 341, 313, 728, 771, 1380, 
 1393, 2397, 1855, 3895, 3861}

Where 171 can be found for n = 10 and 3861 for n = 30. In fact, they all seem to match with my code until n = 30. I haven't tried to go further due to computation time.

---

- Counting the n-gons:

I did write a code for that part thanks to the code above, but it only works properly for even n smaller than 14. For this reason I'm not keen to post it here unless requested.

But thanks to this code I found the following sequence of number of n-gons:

{0, 0, 1, 4, 11, 24, 50, 80, 154, 220}

W|A leading to this sequence:

del[m_, n_] := If[Mod[n, m] == 0, 1, 0]; 
numberOfNGons[n_] := If[n < 3, 
  0, (n^4 - 6 n^3 + 23 n^2 - 42 n + 24)/24 + 
   del[2, n] (-5 n^3 + 42 n^2 - 40 n - 48)/48 - del[4, n] (3 n/4) + 
   del[6, n] (-53 n^2 + 310 n)/12 + del[12, n] (49 n/2) + 
   del[18, n]*32 n + del[24, n]*19 n - del[30, n]*36 n - 
   del[42, n]*50 n - del[60, n]*190 n - del[84, n]*78 n - 
   del[90, n]*48 n - del[120, n]*78 n - del[210, n]*48 n]; 
numberOfNGons[#] & /@ Range@20

{0, 0, 1, 4, 11, 24, 50, 80, 154, 220, 375, 444, 781, 952, 1456, 
 1696, 2500, 2466, 4029, 4500}

Finally, for n = 12 I have indeed 444 n-gons and I can then generate this kind of figure:

---

More information about the theory can be found here and here.

Answer 2

(This should be a comment, but it got too long. In a nutshell: Don't use image processing for this. It's a computational geometry problem, and you should solve it as such. Look up line sweep algorithms, if you're worried about computational complexity. But for n<=30, a simple brute-force algorithm might be fast enough.)

Getting an image processing solution is pretty easy. You already have img, just use

colors = MorphologicalComponents[DeleteBorderComponents[Binarize[img]]];

to assign a unique index to every connected component of white pixels in img. So Max[img] is the total number of connected component, and Colorize[colors] gives an image where each connected component is colored differently:

Unfortunately, this gives you the wrong result. If you look closely in the image above, there are a few single-pixel "components" that are really artifacts from the drawing algorithm. We can highlight them:

smallComponents = 
  ComponentMeasurements[
   DeleteBorderComponents[Binarize[img]], {"Centroid", 
    "Area"}, #2 < 5 &];    
HighlightImage[Darker@Darker@Colorize[colors], 
 smallComponents[[All, 2, 1]]]

So this is really only useful if you want to create pretty pictures or if a rough estimate is good enough.