Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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]]

Mathematica graphics

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

share|improve this question
    
"everything I've tried has failed." What exactly have you tried? :) –  Öskå May 17 at 16:24
    
I edited your question so KSubsets is not needed anymore. –  Öskå May 17 at 16:31
    
@GenericUsrnme Do you want image processing solution or graph based solution with Mathematica. you may check mathematica.stackexchange.com/questions/19546/… belisarius's solution for detecting intersection point using image processing solution. For 2d intersection detection algorithms you can check mathematica.stackexchange.com/questions/24211/… for references form this site. –  s.s.o May 17 at 18:38
    
Please note that for a given graph the number of intersections may vary with the choice of layout method. It's not an intrinsic property of a graph. Try for instance Graph[{1 -> 2, 1 -> 3, 1 -> 5, 2 -> 4, 2 -> 6, 3 -> 4, 3 -> 7, 4 -> 8, 5 -> 6, 5 -> 7, 6 -> 8, 7 -> 8}] and Graph[{1 -> 2, 1 -> 3, 1 -> 5, 2 -> 4, 2 -> 6, 3 -> 4, 3 -> 7, 4 -> 8, 5 -> 6, 5 -> 7, 6 -> 8, 7 -> 8}, GraphLayout -> "PlanarEmbedding"]. BTW Your graph can be generated simply by CompleteGraph[10]. –  Sjoerd C. de Vries May 17 at 20:18
    
Ah, thanks!, @Öskå I'm mainly tried ImageCorner/Keypoints/Lines to try and generate a list for the number of intersections but I've only ever managed to get lists much larger than the real value when I've been testing with small n. For example with n=5 I get 2365 Lines, 1347 Corners when there is 10 and 10 respectively. Past this I have no idea what to do - I'm completely new to the Image Processing scene –  GenericUsrnme May 18 at 11:06

2 Answers 2

up vote 5 down vote accepted

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, PointSize@.015, Point@allpts}, ImageSize -> 350]

Mathematica graphics

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

Mathematica graphics

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:

Mathematica graphics


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

share|improve this answer
    
Thanks! I remember seeing that paper before but I could never find it again. This is really helpful though –  GenericUsrnme Jul 24 at 20:19
    
@GenericUsrnme You are welcome :) That was quite a few times ago but I had fun with that :D You can consider accepting it if you like :) –  Öskå Jul 24 at 21:19

(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:

enter image description here

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]]]

enter image description here

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

share|improve this answer
    
Thanks! Would you be able to provide references to any relevant literature on computational geometry? I'm relatively new to the computational end of things here –  GenericUsrnme Jul 24 at 20:02

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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