问题描述:

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], [email protected]}]

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.

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.

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}}}],{[email protected]#, [email protected]#} &@
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 = La[email protected]@
Reap[Do[Sow[{#[[i]], #[[j]]}], {i, 1, [email protected]# - 1}, {j, i + 1,
[email protected]#}]] &;
```

(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.