20
$\begingroup$

MMA 10 introduced a new function, which can be very convenient: InfiniteLine.

Of course, two infinite lines can be described by different arguments: for example InfiniteLine[{{0,0},{1,0}}] and InfiniteLine[{{0,0},{2,0}}] are identical. How can I delete duplicates in a list of infinite line?

For example,

lines = {InfiniteLine[{{0,0},{1,0}}], InfiniteLine[{{0,0},{2,0}}],
         InfiniteLine[{{0,1},{1,0}}]};
myDeleteDuplicates[lines]

should return

{InfiniteLine[{{0,0},{1,0}}], InfiniteLine[{{0,1},{1,0}}]}

Edit In my original question, I had written

I would like to avoid if possible comparing lines "by hand", i.e. by translating and normalising the arguments of InfiniteLine.

I had not expected this constraint to result in a (possible) significant increase of computation time. Let's lift it, hoping it will not penalise the existing answerers too much.

$\endgroup$

6 Answers 6

10
$\begingroup$

It still feels a little bit wasteful for me to use a trigonometric function so there's room for improvement, but it's not as wasteful as bringing to bear region functionality on this problem:

sameLine[InfiniteLine[{u1_, u2_}], InfiniteLine[{v1_, v2_}]] := With[{u = u1 - u2, v = v1 - v2},
  PossibleZeroQ[VectorAngle[u, v]] || PossibleZeroQ[VectorAngle[u, v] - Pi]
  ]

DeleteDuplicates[lines, sameLine]

{InfiniteLine[{{0, 0}, {1, 0}}], InfiniteLine[{{0, 1}, {1, 0}}]}\

Here is a version with just the square root and multiplication:

sameLine[InfiniteLine[{u1_, u2_}], InfiniteLine[{v1_, v2_}]] := With[{u = u1 - u2, v = v1 - v2},
  PossibleZeroQ[Abs[Dot[u1 - u2, v1 - v2]/(Norm[u1 - u2] Norm[v1 - v2])] - 1]
  ]

or another even simpler form:

sameLine[InfiniteLine[{u1_, u2_}], InfiniteLine[{v1_, v2_}]] := 
 PossibleZeroQ[Dot[u1 - u2, {-1, 1} Reverse[v1 - v2]]]

All of the previous functions have the flaw that they don't count parallel lines as duplicates. We can fix that by adding another condition:

sameLine[InfiniteLine[{u1_, u2_}], InfiniteLine[{v1_, v2_}]] := And[
  PossibleZeroQ[Dot[u1 - u2, {-1, 1} Reverse[v1 - v2]]],
  PossibleZeroQ[Dot[u1 - v1, {-1, 1} Reverse[v1 - v2]]]
  ]
$\endgroup$
5
  • $\begingroup$ It was not obvious to me that I was preventing the optimal way. I edited the question and lifted the constraint. $\endgroup$
    – anderstood
    May 1, 2016 at 17:00
  • 1
    $\begingroup$ @anderstood I added such a version now. Arithmetic operators are cheap, trigonometric functions are not as cheap, and who knows what the higher order region functionality use. If you want something fast you shouldn't be excluding simple arithmetic, it just forces people to use more computationally expensive stuff. $\endgroup$
    – C. E.
    May 1, 2016 at 19:05
  • 1
    $\begingroup$ Thanks. I did not ask explicitly for a solution without arithmetic operators, but for something which did not consist, if possible, in reprogramming everything from scratch. Using DeleteDuplicates is perfectly fine. Your code is much faster, however it does not make the distinction between parallel but distinct lines, such as lines defined by $(0,0),(0,1)$ and $(1,0),(1,1)$. It probably suffices to add a distance test (if parallel and distance is 0, then it's the same line). I'll make a suggestion when I can. $\endgroup$
    – anderstood
    May 2, 2016 at 0:54
  • $\begingroup$ @anderstood You are right, I added something I think works. $\endgroup$
    – C. E.
    May 2, 2016 at 1:59
  • $\begingroup$ Dot[u1 - u2, {-1, 1} Reverse[v1 - v2]] can be simplified to Dot[u1 - u2, Cross[v1 - v2]] or Det[{u1 - u2, v2 - v1}]. $\endgroup$
    – chyanog
    Sep 18, 2020 at 15:38
21
$\begingroup$
DeleteDuplicates[lines, RegionWithin]
{InfiniteLine[{{0, 0}, {1, 0}}], InfiniteLine[{{0, 1}, {1, 0}}]}

Also

DeleteDuplicates[lines, MemberQ[{##}, RegionIntersection @ ##]&]
{InfiniteLine[{{0, 0}, {1, 0}}], InfiniteLine[{{0, 1}, {1, 0}}]}
$\endgroup$
2
  • $\begingroup$ The VectorAngle solution does not work for lines = {InfiniteLine[{{0, 1}, {1, 1}}], InfiniteLine[{{1, 1}, {2, 1}}]}; $\endgroup$ Mar 5, 2021 at 8:50
  • $\begingroup$ Thank you @SjoerdSmit. Removed that part. $\endgroup$
    – kglr
    Mar 5, 2021 at 18:22
11
$\begingroup$

Here's another approach:

DeleteDuplicates[lines, And @@ RegionMember[#, #2[[1]]] &]

(* {InfiniteLine[{{0, 0}, {1, 0}}], InfiniteLine[{{0, 1}, {1, 0}}]} *)
$\endgroup$
2
  • $\begingroup$ I don't know why, but i) this solution is about two times slower than kglr's, and ii) I sometimes end up with 1 duplicate for each element of a list. I'll investigate why. Point ii) could be due to numerical tolerance. $\endgroup$
    – anderstood
    Apr 30, 2016 at 21:22
  • $\begingroup$ @anderstood. Yeah it's probably due to numerical tolerance. I'll also look into it some more later tonight. $\endgroup$
    – RunnyKine
    Apr 30, 2016 at 21:58
9
$\begingroup$

After version 11.1

lines={ InfiniteLine[{{0,0},{1,0}}], InfiniteLine[{{0,0},{2,0}}],
        InfiniteLine[{{0,1},{1,0}}], InfiniteLine[{{0,1},{4,-3}}] };

DeleteDuplicates[lines, RegionEqual]

{InfiniteLine[{{0, 0}, {1, 0}}], InfiniteLine[{{0, 1}, {1, 0}}]}

$\endgroup$
2
$\begingroup$

For a large set of lines, this will be faster

Clear["`*"];
eps=10^-9.;

sameLine1[InfiniteLine@{{x1_,y1_},{x2_,y2_}}]:=
  Sort@Round[{-#,#},eps]&@Normalize[{y1-y2, x2-x1,x1 y2-x2 y1}];

sameLine2[InfiniteLine@{a_,b_},InfiniteLine@{c_,d_}]:=
  Abs@Det[{a-b,d-c}]<eps&&Abs@Det[{a-c,d-c}]<eps;

Length[lines=InfiniteLine /@ RandomSample@Join[RandomReal[1,{400,2,2}],
  Join@@Table[RandomPoint[Line@RandomReal[1,{2,2}],{2,2}],300]]]

Length[r1=DeleteDuplicatesBy[lines,sameLine1]]//AbsoluteTiming
Length[r2=DeleteDuplicates[lines,sameLine2]]//AbsoluteTiming

r1===r2

Output:

1000
{0.0135183, 700}
{2.40766, 700}
True

$\endgroup$
2
$\begingroup$

RegionEqual, like many region functions, is able to compute symbolic results as long as arguments are fully specified. This allows more efficient constructions of the following kind - where the symbolic solution is found and simplified before the testing function is defined:

ClearAll@equalLineQ; 

equalLineQ[InfiniteLine[{{a_, b_}, {c_, d_}}], 
  InfiniteLine[{{e_, f_}, {g_, h_}}]] := 
 Evaluate@FullSimplify@
   RegionEqual[InfiniteLine[{{a, b}, {c, d}}], 
    InfiniteLine[{{e, f}, {g, h}}]]

->

? equalLineQ

equalLineQ[InfiniteLine[{{a_, b_}, {c_, d_}}], InfiniteLine[{{e_, f_}, {g_, h_}}]] := b c + d e + a f == a d + b e + c f && b c + d g + a h == a d + b g + c h

And thus:

DeleteDuplicates[{InfiniteLine[{{0, 0}, {1, 0}}], 
  InfiniteLine[{{0, 0}, {2, 0}}], 
  InfiniteLine[{{0, 1}, {1, 0}}]}, equalLineQ]

{InfiniteLine[{{0, 0}, {1, 0}}], InfiniteLine[{{0, 1}, {1, 0}}]}

Technically this kind of constructs could be entirely automated, but it's surprisingly convoluted, and would clutter this answer to a considerable extent.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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