Message Boards Message Boards

GROUPS:

Double-check if points are on a line?

Posted 2 months ago
664 Views
|
5 Replies
|
5 Total Likes
|

Hi community,

I am a Mathematica beginner and want to solve the following problem. I am sure you can help me.

Task description: For 10 arbitrary points, calculate how many of them are on the same line. How many straights are there? Example P1 (X1, Y1, Z1)

I know how to solve this problem on paper, but i am searching for an applicable solution in mathematica. e.g. create straight between two points (straight-line equation), check if the other 8 points are on this straight by solving the equation system.

Thank you in advance and BR, Gabriel

5 Replies

In[5]:= Linje[a, b, x_] := a + b x (This defines a line with intercept a and a slope b)

In[10]:= Linje[3, 2, {6, 7, 8}] (This sets some parameters for a = 3, b = 2 and three values of x)

Out[10]= {15, 17, 19} (*These are the three outputs (=y)

In[11]:= Plot[3 + 2 x, {x, 2, 10}] (This Plots the line over x, between 2 & 10)

Posted 2 months ago

Here I give a straightforward and simple approach, which very probably could be ameliorated.

Make a list of points

pts = {{1, 2}, {3, 5}, {7, 4}, {4, 8}, {6, 6}, {3, 6}}

Get all pairs of them (two points defining a straight line)

pairs = Flatten[Table[{pts[[i]], pts[[j]]}, {i, 1, Length[pts] - 1}, {j, i + 1, Length[pts]}], 1]

For each pair construct the function (line) through these points

funcs = (#[[1]] + (#[[2]] - #[[1]]) t) & /@ pairs

Now check each function if it hits any other point

hits0 = Flatten[Table[ {i, j, Solve[funcs[[i]] == pts[[j]], t]}, {i, 1, Length[funcs]}, {j, 1, Length[pts]}], 1]

If t is either 0 or 1 these are the generating points of the line in question, if there is no solution (no other point is hit) Solve returns {}. So set the answers to theses cases to {}

hits1 = hits0 /. {{x__, {{t -> 0}}} -> {}, {x__, {{t -> 1}}} -> {}, {x__, {}} -> {}}

Now delete all the {} (which could be done in one step)

hits = DeleteCases[hits1, {}]

and you find for example that function 3 (generated by points {1,2} and { 4,8 } ) hits point {3,6}

In[7]:= funcs[[3]] /. t -> 0
funcs[[3]] /. t -> 1
funcs[[3]] /. t -> 2/3

Out[7]= {1, 2}

Out[8]= {4, 8}

Out[9]= {3, 6}

I think from here on you could solve your original problem. Be careful to eliminate doubles: if a line through p1, p2 hits p3, than a line through p2,p3 hits p1 ( or the line through p1, p3 hits p2 ), but they describe the same line. Therefore there is some further work to be done.

You may want to have a look at

plist = {funcs[[#[[1]]]] /. t -> 0, funcs[[#[[1]]]] /. t -> 1,  funcs[[#[[1]]]] /. #[[3, 1]]} & /@ hits      

DeleteDuplicates[Sort /@ plist]

indicating that that there are 3 points on one line. This is indeed the case

Graphics[{PointSize[.02], Red, Point /@ pts}, Axes -> True]

Try the whole thing with

pts = {{1, 2}, {3, 5}, {7, 4}, {4, 8}, {6, 6}, {3, 6}, {6, 10}, {12, 20}}

Another approach could be

Take a pair of points, define the line function, look if other points are located on this line, if yes, write function and points to another list and delete the points of this line from the original point- list, take the next pair until all pairs are checked.

Posted 2 months ago

Thank you a lot for you support!

The more concise version I described above could be (try to substitute For.... by While...., just as an exercise )

pts = {{1, 2}, {3, 5}, {7, 4}, {4, 8}, {6, 6}, {3, 6}, {6, 10}, {12, 20}};

pts1 = pts;
hitlist = {};
For[i = 1, i < Length[pts] - 1, i++,
 For[j = i + 1, j < Length[pts], j++,
  g = pts[[i]] + (pts[[j]] - pts[[i]]) t;
  For[k = j + 1, k < Length[pts] + 1, k++,
   lsg = Solve[g == pts[[k]], t];
   If[lsg != {},
    AppendTo[hitlist, {pts[[i]], pts[[j]], pts[[k]]}];
    pts = Delete[pts, k]
    ]
   ]
  ]
 ]
hitlist

But a more Mathematica-like procedure would be

pts = {{1, 2}, {3, 5}, {7, 4}, {4, 8}, {6, 6}, {3, 6}, {6, 10}, {12, 20}};
cands = Flatten[
  Table[{i, j, k}, {i, 1, Length[pts] - 2}, {j, i + 1, Length[pts] - 1}, {k, j + 1, Length[pts]}], 2]

Now define a function to check whether 3 points lie on a line

func[{i_, j_, k_}] := Module[{},
  g = pts[[i]] + (pts[[j]] - pts[[i]]) t;
  lsg = Solve[g == pts[[k]], t];
  If[lsg != {},
   {i, j, k, lsg}]
  ]

and apply this function to the "candidates", deleting all negative results

sol = DeleteCases[func /@ cands, Null]

This can of course be translated to the points

Map[pts[[#]] &, Take[#, 3] & /@ sol, {1}]

Nice little problem! The idea here: Making a suitable parametrization of every possible line between two points and looking for doubles.

pts = {{2, 1}, {5, 3}, {4, 7}, {8, 4}, {6, 6}, {6, 3}, {10, 6}, {20, 12}, {15, 6}, {6, 8}};
tup = {pts[[#1]], pts[[#2]]} & @@@ Select[Tuples[Range[Length[pts]], 2], First[#] < Last[#] &];

calcLineParamPts[{{x1_, y1_}, {x2_, y2_}}] := Module[{a, b},
  If[x1 == x2, Return[{{x1, 0}, {x1, 1}}]];
  If[y1 == y2, Return[{{0, y1}, {1, y1}}]];
  a = (y2 - y1)/(x2 - x1);
  b = y1 - a x1;
  {{-b/a, 0}, {(1 - b)/a, 1}}]

lineParam = calcLineParamPts /@ tup;
commonLineParam = First /@ Select[Tally[lineParam], Last[#] > 1 &];

Graphics[{InfiniteLine /@ commonLineParam, Red, PointSize[Large], Point[pts]}]

enter image description here

Addendum:

If you want to know which point lies on which line, you can find out like so:

il = InfiniteLine /@ commonLineParam;
Grid[Function[{infLine}, {infLine, Select[pts, # \[Element] infLine &]}] /@ il, Frame -> All]

enter image description here

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract