Mathematica: Non-intersecting line segments

问题:

How can we tell Mathematica to gives us a set of non-intersecting lines? In this case two lines intersect if they have a point (not an endpoint) in common. Consider this simple case:

l1 = {{-1, 0}, {1, 0}};
l2 = {{0, -1}, {0, 1}};
lines = {l1, l2};

The idea is to create a function which, given a set a lines, returns a set of non-intersecting lines. If such function exists say split then the output of

split[lines]

would be

{
 {{-1, 0}, {0,0}},
 {{ 0, 0}, {1,0}}, 
 {{ 0,-1}, {0,0}}, 
 {{ 0, 0}, {0,1}}
}

The function detected that {0,0} is the intersection between the two lines in the set and in order to have non-intersecting lines it broke the line segments at the intersections thus generating 2 more lines. This process gets more complicated if the original input contains more lines. Does anyone know how to do this efficiently in Mathematica without using loops? It might help to know an algorithm to find if two lines are intersecting.

Note

This question is the second part of my attempt to find out how to make wire frames in Mathematica with hidden line removal. Please feel free to add more appropriate tags.

回答1:

if you assume that split exists, you then need to apply it to all pairs; these may be produced by

ClearAll[permsnodups];
permsnodups[lp_] := DeleteDuplicates[Permutations[lp, {2}],
   ((#1[[1]] == #2[[1]]) &&(#1[[2]] == #2[[2]]) || 
   (#1[[1]] == #2[[2]]) && (#1[[2]] == #2[[1]])) &]

which does this: permsnodups[{a, b, c, d}] gives {{a, b}, {a, c}, {a, d}, {b, c}, {b, d}, {c, d}}, over which you could map your split function (ie these are all pairs, making sure that if {a,b} is there then {b,a} is not since then you are doing twice the work for no reason--it's like doing $\sum_{i,j>i}$ as opposed to $\sum_{i,j}$).

EDIT: Here is an implementation of split (I was stuck with no internet access for half an hour or so, so worked out the relevant equations by hand, and this is not based on the link you gave nor is it optimized or pretty):

ClearAll[split2]
split2[{{ai_, bi_}, {ci_, di_}}] := Module[
{g1, g2, a, b, c, d, x0, y0, alpha, beta},
(*make sure that a is to the left of b*)

If[ai[[1]] > bi[[1]], {a, b} = {bi, ai}, {a, b} = {ai, bi}];
If[ci[[1]] > di[[1]], {c, d} = {di, ci}, {c, d} = {ci, di}];
g1 = (b[[2]] - a[[2]])/(b[[1]] - a[[1]]);
g2 = (d[[2]] - c[[2]])/(d[[1]] - c[[1]]);
If[g2 \[Equal] g1,
    {{a, b}, {c, d}},(*they're parallel*)

alpha = a[[2]] - g1*a[[1]];
    beta = c[[2]] - g2*c[[1]];
    x0 = (alpha - beta)/(g2 - g1);(*intersection x*)

If[(a[[1]] < x0 < b[[1]]) && (c[[1]] < x0 < 
   d[[1]]),(*they do intersect*)
            y0 = alpha + g1*x0;
            {{a, #}, {#, b}, {c, #}, {#, d}} &@{x0, y0},
            {{a, b}, {c, d}}(*they don't intersect after all*)]]]

(in fact it's atrociously slow and ugly). Anyway, you can see that it works like this:

Manipulate[
Grid[{{Graphics[{Line[{p1, p2}, VertexColors \[Rule] {Red, Green}], 
  Line[{p3, p4}]},
        PlotRange \[Rule] 3, Axes \[Rule] True],
        (*Reap@split2[{{p1,p2},{p3,p4}}]//Last,*)
        If[
            Length@split2[{{p1, p2}, {p3, p4}}] \[Equal] 2,
            "not intersecting",
            "intersecting"]}}],
{{p1, {0, 1}}, Locator}, {{p2, {1, 1}}, Locator},
{{p3, {2.3, -.1}}, Locator}, {{p4, {2, 1}}, Locator}]

which produces things like

and

(you can move the locators around). Mind you, my split2 divides by zero whenever one of the lines is vertical (this can be fixed but I haven't done it).

In any case this is all very slow and ugly. It could be made faster by compiling and making listable (and using the link you gave), but my current coffee break is over (or was over half an hour ago). I'll try to get back to this later.

Meanwhile, do ask if there are any concrete questions (eg, if you can't see what breaks for vertical lines). And note that while this does what you ask, if you do map over a list of lines you'll end up with a ragged list which you will have to flatten. But, this is what you asked for :)

回答2:

For determining the intersection, you can also do the following parametric approach, that does not suffer from the usual problems of methods involving the cartesian equations (ie division by zero ...):

f[t_, l_List] := l[[1]] + t (l[[2]] - l[[1]])
split[l1_, l2_] := Module[{s},
  If[(s = ToRules@
       Reduce[f[t1, l1]==f[t2, l2] && 0 <t2< 1 && 0 <t1< 1, {t1,t2},Reals]) =={},
   Return[{l1, l2}],
   Return[{{f[0, l1], f[t1, l1] /. s}, {f[1, l1], f[t1, l1] /. s},
           {f[0, l2], f[t2, l2] /. s}, {f[1, l2], f[t2, l2] /. s}}]
   ]]