Wolfram Function Repository

Instant-use add-on functions for the Wolfram Language

Function Repository Resource:

 FindExtraordinaryLines

Source Notebook

Return the lines passing through three or more points, given a set of points

Contributed by: Ed Pegg Jr

ResourceFunction["FindExtraordinaryLines"][pts]

returns indices for sets of three or more points in pts lying on the same line.

Details

For a finite set of points, a line going through only two points is called an ordinary line.

Examples

Basic Examples (2) 

Here are 11 points that make 15 lines of three points each:

In[1]:=
pts = {{0, 0}, {6, -6}, {-6, 6}, {-2, -6}, {2, 6}, {6, 6}, {-6, -6}, {-6, 0}, {6, 0}, {0, 3}, {0, -3}}; lines = ResourceFunction["FindExtraordinaryLines"][pts]
Out[2]=

A graphic showing the points and lines:

In[3]:=
Graphics[{Green, Line[pts[[#]]] & /@ lines, Black, Table[Style[Text[n, pts[[n]]], 20], {n, 1, Length[pts]}]}]
Out[3]=

Scope (4) 

Find all the lines of 3 or more points in a 3×3×3 lattice:

In[4]:=
pts = Tuples[Range[3], {3}]; lines = ResourceFunction["FindExtraordinaryLines"][pts]
Out[5]=
In[6]:=
Graphics3D[{Green, Tube[pts[[#]]] & /@ lines, Black, Table[Style[Text[n, pts[[n]]], 20], {n, 1, Length[pts]}]}]
Out[6]=

Here is a set of 20 lattice points where all lines are ordinary:

In[7]:=
pts = {{1, 5}, {1, 6}, {2, 3}, {2, 8}, {3, 2}, {3, 9}, {4, 4}, {4, 7}, {5, 1}, {5, 10}, {6, 1}, {6, 10}, {7, 4}, {7, 7}, {8, 2}, {8, 9}, {9, 3}, {9, 8}, {10, 5}, {10, 6}}; lines = ResourceFunction["FindExtraordinaryLines"][pts]
Out[8]=
In[9]:=
Graphics[{Green, Line[pts[[#]]] & /@ lines, Black, Table[Style[Text[n, pts[[n]]], 20], {n, 1, Length[pts]}]}]
Out[9]=

Most sets of 20 points from this lattice will have many extraordinary lines:

In[10]:=
pts = Sort[RandomSample[Tuples[Range[10], {2}], 20]]; lines = ResourceFunction["FindExtraordinaryLines"][pts]
Out[10]=
In[11]:=
Graphics[{Green, Line[pts[[#]]] & /@ lines, Black, Table[Style[Text[n, pts[[n]]], 20], {n, 1, Length[pts]}]}]
Out[11]=

Find lines going through powers of a complex solution for x3=x+1:

In[12]:=
pts = Table[ReIm[Root[-1 - # + #^3& , 2, 0]^k], {k, 0, 18}]; lines = ResourceFunction["FindExtraordinaryLines"][pts]
Out[12]=
In[13]:=
Graphics[{Green, Line[pts[[#]]] & /@ lines, Black, Table[Style[Text[n, pts[[n]]], 20], {n, 1, Length[pts]}]}]
Out[13]=

Requirements

Wolfram Language 11.3 (March 2018) or above

Version History

  • 2.0.1 – 22 November 2021

License Information