Polygon with an Extended Boundary

Question

I have a (not necessarily convex) Polygon, and want to create another Region that can be seen as an extended boundary of the first polygon.

It should be quite simple; I tried it by creating a second polygon with 10% larger size, that I shift. It works for simple shapes such as squares, but it doesn't produce a boundary for different shapes.

myCoordinates = {{0, 0}, {0, 1}, {1, 1}, {1, 0}};
mypolygon = Polygon[myCoordinates];
dilatation = 1.1;
maxX = Max[myCoordinates[[;; , 1]]];
maxY = Max[myCoordinates[[;; , 2]]];
myCoordinatesLarge = dilatation*myCoordinates;
myCoordinatesLarge[[;; , 1]] -= (dilatation - 1)*maxX/2;
myCoordinatesLarge[[;; , 2]] -= (dilatation - 1)*maxY/2;
mypolygon2 = Polygon[myCoordinatesLarge];

RR = RegionIntersection[mypolygon2, mypolygon]
Show[Graphics[{LightBlue, EdgeForm[Gray], mypolygon, mypolygon2}], HighlightMesh[DiscretizeRegion[RR], 2]]

However, if my coordinates are

myCoordinates = {{0, 0}, {0, 1}, {3, 0}};

then I get this area without a boundary at the hypotenuse

The best would be to start from RegionCentroid[mypolygon] and inflate the polygon without changing its RegionCentroid, but I don't know how to do this.

Update: The method in the answers works for simple shapes such as squares or triangles, but if I have slightly more complex shapes, the result has no real boundary

myCoordinates = {{0, 0}, {0, 1}, {1, 1}, {2, 0}, {0.5, 0.5}};
mypolygon = Polygon[myCoordinates];
mypolygon2 = TransformedRegion[mypolygon, ScalingTransform[{2, 2}, RegionCentroid[mypolygon]]];
RR = RegionIntersection[mypolygon2, mypolygon];
Show[Graphics[{LightBlue, EdgeForm[Gray], mypolygon, mypolygon2}], HighlightMesh[DiscretizeRegion[RR], 2]]

Answer 1

Here is a function that inflates a polygon. It creates a new polygon whose sides are parallel to the original, but displaced by a specified difference. Actually, it takes the coordinates of polygon vertices, not a Polygon object. Here's the function definition:

Clear[inflate]
inflate[gap_, pts_] := With[{
   c = Join[pts[[-1 ;;]], pts, pts[[;; 1]]]},
  Table[Block[{dir1, dir2, dist1, dist2,
     p1, p2, p3, perp1, perp2, q1, q2, q3, q4, x, y},
    {p1, p2, p3} = {c[[n - 1]], c[[n]], c[[n + 1]]};
    {dist1, dist2} = Norm /@ {p2 - p1, p3 - p2};
    {dir1, dir2} = {p2 - p1, p3 - p2}/{dist1, dist2};
    {perp1, perp2} = {{-Last[dir1], First[dir1]}, 
       {-Last[dir2], First[dir2]}};
    {q1, q2} = With[{delta = gap*perp1}, {p1 + delta, p2 + delta}];
    {q3, q4} = With[{delta = gap*perp2}, {p2 + delta, p3 + delta}];
    eqn1 = With[{delta = q2 - q1, pt = {x, y} - q1},
      First[delta] Last[pt] == Last[delta] First[pt]];
    eqn2 = With[{delta = q4 - q3, pt = {x, y} - q3},
      First[delta] Last[pt] == Last[delta] First[pt]];
    {x, y} /. First@Solve[{eqn1, eqn2}, {x, y}]],
   {n, 2, Length[pts] + 1}]]

Here is an example of how it can be used with one of your coordinate lists.

coords = {{0, 0}, {0, 1}, {1, 1}, {2, 0}, {1/2, 1/2}};
poly1 = Polygon[coords];
Manipulate[
 poly2 = Polygon[offset[gap, coords]];
 Show[Graphics[{EdgeForm[Gray], Opacity[1/3], Blue, poly1,
    EdgeForm[Black], LightBlue, poly2}],
  PlotRange -> {{-1, 4}, {-1, 2}}, Axes -> True],
 {{gap, 1/4}, 0, 1/2, Appearance -> "Labeled"}]

How does it work?
Take three consecutive vertices, $p_1$, $p_2$, $p_3$. The line $p_1p_2$ gets moved perpendicular to itself, and $p_2p_3$ moves perpendicular to itself. The intersection of the new lines is a vertex of the inflated polygon.

So, calculate the direction (cosines) from $p_1$ to $p_2$, then find the perpendicular direction. Translate $p_1$ and $p_2$ by the gap distance to points $q_1$ and $q_2$. Likewise, translate $p_2$ and $p_3$ perpendicular to $p_2p_3$ to get points $q_3$ and $q_4$. Use the two-point form to get equations for lines $q_1q_2$ and $q_3q_4$. Solve the equations for the intersection.

Use Table to loop over the list of coordinates. To make the iteration easier, use With to extend the coordinate list forward and backwards. This implementation is pretty inefficient: each direction, displacement, equation, etc., is calculated twice.

The same function will deflate a polygon if the gap is negative, or if the coordinate list is reversed.

Answer 2

ClearAll[polygonInflate]
polygonInflate[δ_][coords_] := Module[{inflines = InfiniteLine /@ 
     Partition[coords, 2, 1, {1, 1}], 
   trs = TranslationTransform /@ (δ (Cross /@ 
     Normalize /@ Differences[Append[coords, First@coords]]))},
  RegionIntersection @@@ 
     Partition[MapThread[TransformedRegion, {inflines, trs}], 2, 1, {1, 1}] /. 
       Point[x_] :> x]

Examples:

myCoordinates1 = {{0, 0}, {0, 1}, {3, 0}};

Graphics[{ Opacity[.5], Red, Polygon@myCoordinates1, Blue, 
  Polygon @ polygonInflate[-.1] @ myCoordinates1}, 
 PlotRange -> RegionBounds[Polygon@myCoordinates1], 
 PlotRangePadding -> Scaled[.1], ImageSize -> Large]

myCoordinates2 = {{0, 0}, {0, 1}, {1, 1}, {2, 0}, {0.5, 0.5}};

Graphics[{ Opacity[.5], Red, Polygon@myCoordinates2, Blue, 
  Polygon @ polygonInflate[-.1] @ myCoordinates2}, 
 PlotRange -> RegionBounds[Polygon@myCoordinates2], 
 PlotRangePadding -> Scaled[.1], ImageSize -> Large]

SeedRandom[77]
myCoordinates3 = Reverse@#[[Most@Last@FindShortestTour[#]]] &@RandomReal[5, {12, 2}];

Graphics[{ Opacity[.5], Red, Polygon @ myCoordinates3, Blue, 
  Polygon @ polygonInflate[-.2] @ myCoordinates3}, 
 PlotRange -> RegionBounds[Polygon @ myCoordinates3], 
 PlotRangePadding -> Scaled[.1], ImageSize -> Large]

Show[Graphics[{Opacity[.5], Red, Polygon @ myCoordinates3}], 
 DiscretizeRegion[Polygon @ polygonInflate[-.2] @ myCoordinates3]], 
 PlotRange -> RegionBounds[Polygon @ myCoordinates3], 
 PlotRangePadding -> Scaled[.1], ImageSize -> Large]

Update: Slightly streamlined implementation of @LouisB's cool idea:

Clear[findCoordsF, inflateF]
findCoordsF[gap_] := Module[{perps, eqns, x, y, difs = Differences[#], 
     disps = #[[;; 2]] + gap (Cross /@ Normalize /@ Differences[#])},
    perps = {x, y} - # & /@ disps;
    eqns = difs[[#, 1]] perps[[#, 2]] == difs[[#, 2]] perps[[#, 1]] & /@ {1, 2};
    {x, y} /. First@Solve[eqns, {x, y}]] &;

inflateF[gap_][pts_] := findCoordsF[gap] /@ Partition[pts, 3, 1, {2, 2}]

coords = myCoordinates2;
Manipulate[Graphics[{EdgeForm[Gray], Opacity[1/3], Blue, Polygon[c], 
    EdgeForm[Black], LightBlue, Polygon[inflateF[gap][c]]}, 
  PlotRange -> All, Axes -> False], 
 {{gap, .1}, -1/2, 1/2, Appearance -> "Labeled"},
 {{c, coords}, Locator}]

Answer 3

You can use TransformedRegion with a ScalingTransform. Your polygon:

p = Polygon[{{0, 0}, {0, 1}, {3, 0}}];

Using TransformedRegion:

extended = TransformedRegion[
    p,
    ScalingTransform[{1.1, 1.1}, RegionCentroid[p]]
]

Polygon[{{-0.10000000000000009, -0.03333333333333338}, {-0.10000000000000009, 1.0666666666666667}, {3.2, -0.03333333333333338}}, {1, 3, 2}]

Check:

Graphics[{Red, extended, Blue, p}]

Answer 4

This is the same as Louis's idea, but I was able to devise a much shorter implementation, which does not rely on Solve[]:

(* intersection of two lines; cf. https://mathematica.stackexchange.com/a/85903 *)
lis[{{p1_, d1_}, {p2_, d2_}}] := With[{sol = LeastSquares[Transpose[{d1, d2}], p2 - p1]}, 
    Mean[{p1 + sol[[1]] d1, p2 - sol[[2]] d2}]]

(* https://mathematica.stackexchange.com/a/22587 *)
PolygonSignedArea[pts_?MatrixQ] := Total[Det /@ Partition[pts, 2, 1, 1]]/2

PolygonInflate[Polygon[p1_?MatrixQ], h_?NumericQ] := Module[{sides, sig},
       sig = Sign[PolygonSignedArea[p1]];
       sides = With[{d = Normalize[Subtract @@ #]}, {Mean[#] + h sig Cross[d], d}] & /@
               Partition[p1, 2, 1, 1];
       Polygon[RotateRight[lis /@ Partition[sides, 2, 1, 1]]]]

As a demonstration:

p1 = {{0, 0}, {0, 1}, {1, 1}, {2, 0}, {1/2, 1/2}};

Manipulate[Graphics[{{Red, PolygonInflate[Polygon[p1], h]},
                     {Opacity[1/2, Blue], Polygon[p1]}},
                    PlotRange -> {{-1, 3}, {-1, 3}}],
           {{h, 0}, -1, 1}]

A more difficult example:

poly = Graphics`PolygonUtils`PolygonData["Test01", "Polygon"];

Graphics[{{Red, PolygonInflate[poly, 1/5]}, {Blue, poly},
          {Yellow, PolygonInflate[poly, -1/5]}}]