# 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 Answer
5 Replies
Sort By:
Posted 2 months ago
 In:= Linje[a, b, x_] := a + b x (This defines a line with intercept a and a slope b)In:= Linje[3, 2, {6, 7, 8}] (This sets some parameters for a = 3, b = 2 and three values of x)Out= {15, 17, 19} (*These are the three outputs (=y)In:= Plot[3 + 2 x, {x, 2, 10}] (This Plots the line over x, between 2 & 10) Answer
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 = (#[] + (#[] - #[]) 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:= funcs[] /. t -> 0 funcs[] /. t -> 1 funcs[] /. t -> 2/3 Out= {1, 2} Out= {4, 8} Out= {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[[#[]]] /. t -> 0, funcs[[#[]]] /. t -> 1, funcs[[#[]]] /. #[[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 beTake 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. Answer
Posted 2 months ago
 Thank you a lot for you support! Answer
Posted 2 months ago
 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}] Answer
Posted 2 months ago
 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]}] 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]  Answer