Mathematica: Joining line segments

Question

This is part one of my attempt to find an answer to my question wireframes in Mathematica.

Given a set of line segments how does one join two segments that are connected AND lie on the same line. For instance consider the line segments l1 = {(0,0), (1,1)} and l2 = {(1,1), (2,2)}. These two line segments can be combined into one line segment, namely l3 = {(0,0), (2,2)}. This is because l1 and l2 share the point (1,1) and the slope of each line segment is the same. Here is a visual:

l1 = JoinedCurve[{{{0, 2, 0}}}, {{{0, 0}, {1, 1}}}, CurveClosed -> {0}];
l2 = JoinedCurve[{{{0, 2, 0}}}, {{{1, 1}, {2, 2}}}, CurveClosed -> {0}];
Graphics[{Red, l1, Blue, l2}, Frame -> True]

One thing to notice is that in the above example l1 and l2 can be combined into one line specified by 3 points, i.e. {{0,0},{1,1},{2,2}}.

The first part of this question is: Given a set of line segments specified by 2 points, how do you reduce this set to have a set with the minimum amount of duplicate points. Consider this made up example:

lines = {
  {{0,0}, {1,1}},
  {{3,3}, {2,2}},
  {{2,2}, {1,1}},
  {{1,1}, {0.5,0.5}},
  {{0,1}, {0,2}},
  {{2,3}, {0,1}}
}

What I want is a function say REDUCE that gives me the following output:

R = {
{{0,0}, {1,1}, {2,2}, {3,3}},
{{1,1}, {0.5,0.5}},
{{2,1}, {0,1}, {0,2}}
}

The only duplicate we need is {1,1}. The way I did this was as follows: I put the first line in R Then I looked at the next line in lines and noticed that no end point matches an endpoint in the lines of R so I added this new line to R. The next line in lines is {{2,2},{1,1}}, the endpoint {1,1} matches the first line in R so I appended {2,2} to line in R. Now I add {{1,1}, {0.5,0.5}} to R and I also add {{0,1}, {0,2}}. Since the last line in lines has an endpoint that matches one in R I appended it and so we have {{2,1}, {0,1}, {0,2}}. Finally I look at all the lines in R and see if any of the endpoints match, in this case the line {{3,3}, {2,2}} matches the right endpoint of the first line in R so I append {3,3} thus eliminating the need for {2,2}.

This may not be the best way to do it, in the sense that it may not give you the best reduction. In any case, assuming that we have this reduction function then we can check if we need all the points to describe a line. This can be done as follows:

If we have more than 3 points describing the line, check if the first 3 points are collinear, if they are, remove the middle one and do the check on the set of the 2 endpoints and a new point. If they are not collinear then shift by one point and check the next 3 points.

The reason I'm asking this question is because I want to reduce the amount of points needed to describe a 2D figure. Try the following:

g1 = ListPlot3D[
   {{0, -1, 0}, {0, 1, 0}, {-1, 0, 1}, {1, 0, 1}, {-1, 1, 1}},
   Mesh -> {2, 2},
   Boxed -> False,
   Axes -> False,
   ViewPoint -> {2, -2, 1},
   ViewVertical -> {0, 0, 1}
]

The following Mathematica 8 function changes a 3D object into a list of lines (a line is a list of 2 points) that describe the wire frame of the object:

G3TOG2INFO[g_] := Module[{obj, opt},
  obj = ImportString[ExportString[g, "PDF", Background -> None], "PDF"][[1]];
  opt = Options[obj];
  obj = Cases[obj, _JoinedCurve, \[Infinity]];
  obj = Map[#[[2]][[1]] &, obj];
  {obj, opt}
]

Note that in Mathematica 7 we have to substitude _JoinedCurve by _Line. Applying the function on g1 we obtain

{lines, opt} = G3TOG2INFO[g1];
Row[{Graphics[Map[Line[#] &, lines], opt], Length@lines}]

There are 90 line segments in there but we only need 12 (If I didn't make any mistake on the counting of straight lines).

So there you have the challenge. How do we manipulate lines to have minimum amount of information needed to describe the figure.

Answer 1

In case this is still interesting, here is a different implementation:

ClearAll[collinearQ]
collinearQ[{{{x1_, y1_}, {x2_, y2_}}, {{x3_, y3_}, {x4_, y4_}}}] := (
 (y1 - y2)*(x1 - x3) == (y1 - y3)*(x1 - x2)) && (y1 - y2)*(x1 - x4) == 
  (y1 - y4)*(x1 - x2)

ClearAll[removeExtraPts];
removeExtraPts[{{{x1_, y1_}, {x2_, y2_}}, {{x3_, y3_}, {x4_, y4_}}}] :=
If[collinearQ[{{{x1, y1}, {x2, y2}}, {{x3, y3}, {x4, y4}}}],{First@#, Last@#} &@
 SortBy[{{x1, y1}, {x2, y2}, {x3, y3}, {x4, y4}}, #[[1]] &],
    {{{x1, y1}, {x2, y2}}, {{x3, y3}, {x4, y4}}}]

so that if lines={{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}} then it returns {{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}} while if lines2 = {{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}} then removeExtraPts[lines2] gives {{0, 0}, {2, 2}}.

This works for vertical lines, horizontal lines etc (there's no danger of dividing by zero).

If what you have is a list of lines, you can produce all distinct pairings between them thus:

ClearAll[permsnodupsv2]
permsnodupsv2 = Last@Last@
 Reap[Do[Sow[{#[[i]], #[[j]]}], {i, 1, Length@# - 1}, {j, i + 1, 
    Length@#}]] &;

(you can do it functionally the way I described here but I find this easier to understand this version at a glance). For example,

 lines = {l1, l2, l3, l4, l5, l6, l7, l8, l9}; 
 permsnodups[lines]
 (*
 ---> {{l1, l2}, {l1, l3}, {l1, l4}, {l1, l5}, {l1, l6}, {l1, l7}, {l1, l8}, 
       {l1, l9}, {l2, l3}, {l2, l4}, {l2, l5}, {l2, l6}, {l2, l7}, 
       {l2, l8}, {l2, l9}, {l3, l4}, {l3, l5}, {l3, l6}, {l3,l7}, 
       {l3, l8}, {l3, l9}, {l4, l5}, {l4, l6}, {l4, l7}, {l4, l8}, 
       {l4, l9}, {l5, l6}, {l5, l7}, {l5, l8}, {l5, l9}, {l6, l7}, 
       {l6, l8}, {l6, l9}, {l7, l8}, {l7, l9}, {l8, l9}}
 *)

and if l1={{pt1,pt2},{pt3,pt4}} and so on, you can simply map removeExtraPts over this, flatten the result (using something like Flatten[#,1]&, but the exact format depends on your input structure) and repeat until it stops changing (as @Verbeia said, you may use FixedPoint to make it stop once it no longer changes). This should join all the lines up.

Answer 2

Step 1 is to find if the lines are on the same projection. This is true if the slope of the first line equals the slope of the constructed line segment from the second-last point of the first line to the second point of the second line.

I don't have Mathematica on my work machine so I can't test this out (there might be syntax errors), but something like the following should work:

(( #2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) ==
(( #1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])) & 
 @@@ (Transpose[{Most[lines],Rest[lines]}])

Essentialy all this does is test that "rise over run" for the first line equals "rise over run" for the joined line segment.

I am assuming that :lines: is not a list of JoinedCurve elements, but a simple list of n*2 lists of points. I am also assuming that the pairs of points defining each line segment are in a canonical order with the points in ascending order in x-direction. That is, the value of first element of the first point is lower than the first element of the second point. If not, sort them first.

Step 2 is actually joining the points. This applies the test in Step 1 and then replaces the two lines with a single joined line. You could wrap this in FixedPoint to join all the lines that are in the same projection.

If[(( #2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) ==
(( #1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])), {#1[[-2]],#2[[2]]}] & 
 @@@ (Transpose[{Most[lines],Rest[lines]}])

This all assumes that the pairs of lines you want to compare are adjacent in the list. If they could be any of the lines in your collection, then you first need to generate a list of all possible pairs of lines to be compared, e.g. using Tuples[listOfLines, {2}], instead of the Transpose function above.

Ok, putting this all together:

f = If[(( #2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) ==
(( #1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])), {#1[[-2]],#2[[2]]}] & ;
FixedPoint[f @@@ #, Tuples[Sort[listOfLines],{2}] ]

I have broken out the Step 2 test-and-replace function into a named pure function so that the #s don't get confused.