18
$\begingroup$

If you consider the following Polygon:

coor = {{6, 0}, {6, 1}, {4, 0}, {5, 2}};
(* and coor = {{7, 2}, {7, 1}, {5, 2}, {6, 1}} *)
pol = Polygon@coor;
Graphics@pol

Mathematica graphics

I would like to know if there is any way to rebuild it automatically in order to remove the self intersection.

Self intersection can be check thanks to J.M.'s comment by:

interPolQ = Not@Graphics`Mesh`SimplePolygonQ[#]&;
interPolQ@pol

True

Knowing that Graphics`Mesh`SimplePolygonQ[] is undocumented I'm wondering if there is a hidden built-in function for that purpose as well.

The output should look like the following and have for coordinates desiredcoor:

coor = {{6, 0}, {6, 1}, {4, 0}, {5, 2}};
desiredcoor = {{4, 0}, {6, 0}, {6, 1}, {5, 2}};
Graphics[{EdgeForm[Dashed], FaceForm@Opacity@.2, Polygon@{coor, desiredcoor}}]

Mathematica graphics

Improve this question
$\endgroup$
5
  • 1
    $\begingroup$ I guess you're not after the convex hull, but for clarity you could show an example showing the before and after and also showing that the result isn't the convex hull $\endgroup$
    – Dr. belisarius
    May 18, 2014 at 23:09
  • $\begingroup$ The result should fill the white spaces as well. I'm going to edit it. $\endgroup$
    – Öskå
    May 18, 2014 at 23:11
  • $\begingroup$ @belisarius I might need ConvexHull indeed.. :) That's uber perfect. I still don't know what a convex hull is but at least I know what it does. $\endgroup$
    – Öskå
    May 18, 2014 at 23:23
  • 2
    $\begingroup$ Be careful. The convex hull may "eat up" some of your vertices. For example, if you add one more vertex inside your grayed area, it won't show up in the convex hull. $\endgroup$
    – Dr. belisarius
    May 18, 2014 at 23:29
  • 1
    $\begingroup$ Previously: @ybeltukov's "deintersection" algorithm. $\endgroup$
    – user484
    May 19, 2014 at 7:32

2 Answers 2

Reset to default
15
$\begingroup$

The question is a little underspecified, so I'll discuss two options.

SeedRandom[0];
coords = RandomReal[1, {6, 2}];
drawPolygon[coords_, color_] := {PointSize[Large], color, Point@coords, 
  FaceForm[Opacity[0.2]], EdgeForm[Directive[Thick, color]], Polygon@coords}
Graphics[drawPolygon[coords, Red]]

enter image description here

As suggested by @belisarius, the convex hull does not self-intersect, but can drop points:

Needs["ComputationalGeometry`"];
chCoords = coords[[ConvexHull[coords]]];
Graphics[drawPolygon[chCoords, Darker@Green]]

enter image description here

If you want to preserve all the points but remove self-intersections, you can try using the travelling salesman tour:

stCoords = coords[[Last@FindShortestTour[coords]]];
Graphics[drawPolygon[stCoords, Blue]]

enter image description here

This approach solves a strictly harder problem than just finding an intersection-free polygon, though, so maybe a simpler solution is possible.

Caveat: For large datasets, Mathematica finds a suboptimal tour, and it's possible that the tour self-intersects.

coords = RandomReal[{0, 1}, {200, 2}];
stCoords = coords[[Last@FindShortestTour[coords]]];
Graphics[drawPolygon[stCoords, Blue]]

enter image description here

To remove those intersections, we can use @ybeltukov's "deintersection" algorithm on the computed tour.

SignedArea[p1_, p2_, p3_] := 
  0.5 (#1[[2]] #2[[1]] - #1[[1]] #2[[2]]) &[p2 - p1, p3 - p1];
IntersectionQ[p1_, p2_, p3_, p4_] := 
  SignedArea[p1, p2, p3] SignedArea[p1, p2, p4] < 0 && 
   SignedArea[p3, p4, p1] SignedArea[p3, p4, p2] < 0;
Deintersect[p_] := 
  Append[p, 
     p[[1]]] //. {s1___, p1_, p2_, s2___, p3_, p4_, s3___} /; 
      IntersectionQ[p1, p2, p3, p4] :> ({s1, p1, p3, 
       Sequence @@ Reverse@{s2}, p2, p4, s3}) // Most;
dstCoords = Deintersect[stCoords];
Graphics[drawPolygon[dstCoords, Purple]]

enter image description here

One might ask, why not simply apply Deintersect on the original coordinates? Well, one can, but it takes an extremely long time.

dCoords = Deintersect[coords];
Graphics[drawPolygon[dCoords, Orange]]

enter image description here

Improve this answer
$\endgroup$
9
  • $\begingroup$ It would be interesting to see where ShortestTour draws the line in terms of an optimal solution (since it claims to find these for "small" numbers of vertices). $\endgroup$
    – Yves Klett
    May 19, 2014 at 9:38
  • 1
    $\begingroup$ It's weird that FindShortestTour doesn't remove intersections as a post-processing step. IIRC, finding&removing intersections is a O(n*log(n)) operation if done right, and it's guaranteed to make the tour shorter. $\endgroup$
    – Niki Estner
    May 19, 2014 at 9:48
  • $\begingroup$ These are both good points that I don't know the answer to! =) $\endgroup$
    – user484
    May 19, 2014 at 9:51
  • 1
    $\begingroup$ The problem is that nikie's answer doesn't seem to work with my test case. See here. $\endgroup$
    – Öskå
    May 19, 2014 at 18:03
  • 1
    $\begingroup$ @Öskå: You're right, I forgot that SortBy treats exact values and machine-precision values differently. Try using N@ArcTan[... or N[pts] instead, then SortBy should sort them properly. $\endgroup$
    – Niki Estner
    May 19, 2014 at 18:19
13
$\begingroup$

One simple way to get an intersection-free tour would be to

  • choose a center point (e.g. arithmetic mean of the vertices)
  • sort the other points clockwise around that center

then the polygon should be the graph of a positive function in a polar plot, so it shouldn't intersect.

I've tested it with some random point sets:

pts = RandomReal[{0, 1}, {200, 2}];
ListLinePlot[Append[pts, pts[[1]]], AspectRatio -> Automatic]

enter image description here

(* get the center point *)
center = Mean[pts];

(* sort by angle *)
pts = SortBy[pts, N[ArcTan @@ (# - center)] &];

(* display result *)
ListLinePlot[Append[pts, pts[[1]]], Epilog -> {Red, Point[center]}, 
 AspectRatio -> Automatic]

enter image description here

I think if two points get the same angle from the starting point, this should still work, but if there's a chance that three or more points lie on a straight line through the starting point, you should sort by {angle, radius} instead.

Improve this answer
$\endgroup$
1
  • 2
    $\begingroup$ "…you should sort by {angle, radius} instead." - that is, SortBy[pts, {N[ArcTan @@ (# - center)] &, N[EuclideanDistance[center, #]] &}] $\endgroup$
    – J. M.'s persistent exhaustion ♦
    Jul 3, 2015 at 2:58

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