A simpler or more concise way to divide the boundary of a polygon into equal arc lengths?

Question

I am really looking just for the least amount of code needed to do this but it is still readable.

Here is the same polygon but the border is respectively split up into 10, 20, and 30 points along the perimeter:

The code I used to produce this is:

OrderVerticesClockwise[pts_List] := Module[
  {pivot, sorted, remainingPoints},
  
  (* Find the pivot: the lowest and leftmost point *)
  pivot = First[SortBy[pts, {Last, First}]];
  
  (* Remove the pivot from the list *)
  remainingPoints = DeleteCases[pts, pivot];
  
  (* Sort the remaining vertices based on the polar angle relative to the pivot *)
  sorted = SortBy[remainingPoints, ArcTan[#[[1]] - pivot[[1]], #[[2]] - pivot[[2]]] &];
  
  (* Return ordered vertices with the pivot at the beginning *)
  Prepend[sorted, pivot]
]

Clear[EquidistantPoints];

EquidistantPoints[pts_List, n_Integer] := Module[
  {
    closedPts = Append[pts, First[pts]],
    lengths, totalLength, interval, accumulatedLengths, currentPt, nextPt,
    distRemaining, currentIndex, result = {}
  },
  
  lengths = EuclideanDistance @@@ Partition[closedPts, 2, 1];
  totalLength = Total[lengths];
  interval = totalLength/n;
  
  accumulatedLengths = Accumulate[lengths];
  
  Do[
    distRemaining = i*interval;
    currentIndex = 1;
    
    While[distRemaining > accumulatedLengths[[currentIndex]],
      currentIndex++;
    ];
    
    distRemaining -= If[currentIndex > 1, accumulatedLengths[[currentIndex - 1]], 0];
    
    currentPt = closedPts[[currentIndex]];
    nextPt = closedPts[[currentIndex + 1]];
    
    AppendTo[result, currentPt + (distRemaining/lengths[[currentIndex]]) * (nextPt - currentPt)];
    
    , {i, 0, n - 1}
  ];
  
  result
]

equiArcLengthPointQuantity=20;
poly = RandomPolygon[12];
vertices = PolygonCoordinates[poly];
orderedVertices = OrderVerticesClockwise[vertices];
equiArcDistances = Accumulate[Table[Perimeter[poly]/equiArcLengthPointQuantity, {i, 1, equiArcLengthPointQuantity}]];
equidistantPts = EquidistantPoints[orderedVertices, equiArcLengthPointQuantity];

Graphics[
  {Polygon[orderedVertices], Red, PointSize[0.02], Point[equidistantPts]}
]

I would assume that there is a much simpler way of doing this, but I couldn't think of one. And I don't know what else to call these points. They aren't equally distanced points in Euclidean space, just along the perimeter by arc length.

Answer 1

• MeshFunctions -> {"ArcLength"} partly work.

poly = RandomPolygon[10];
plot=ListLinePlot[Append[#, First@#] &@poly[[1]], 
 MeshFunctions -> {0 &, "ArcLength"}, Mesh -> {Subdivide@10}, 
 MeshStyle -> Red, Epilog -> {Opacity[.2], poly}, Axes -> False]

pts =Cases[plot // Normal, Point[p_] :> p, -1] // DeleteDuplicates

Answer 2

We first create the points of a random polygon:

m = 10 ; (* polygon *)
pts = CirclePoints[m];
pts = RandomReal[{0.1, 2}] # & /@ pts;
AppendTo[pts, pts[[1]]];

Then we calculate the lines and their lengths of the border:

border = Partition[pts, 2, 1];
dist = Total[Norm[Subtract @@ #] & /@ border]/n;

Finally we distribute the points along the perimeter:

n = 12;(* number of points *)
rest = 0;
pts1 = Reap[Sow[pts[[1]]];
    Scan[(tmp = #[[1]];
       While[rest + Norm[#[[2]] - tmp] >= dist,
        Sow[
         tmp = tmp + (dist - rest)/Norm[#[[2]] - tmp] (#[[2]] - tmp)];
         rest = 0;];
       rest = Norm[#[[2]] - tmp]) &, border]
    ][[2, 1]];
Graphics[{Line[pts], Red, PointSize[0.03], Point[pts1]}]

Answer 3

My primary tool is Interpolation:

 With[{poly = RandomPolygon[10], n = 50},
  With[{len = ArcLength@RegionBoundary@poly},
   (* Get a sequence of line segments. *)
   Partition[MeshPrimitives[poly, 2][[1, 1]] // Append[#, First@#] &, 
      2, 1, 1] //
     (* Create a linear constant-speed interpolation
        through polygon vertices. *)
     Interpolation[
       Transpose[
        {Accumulate[
          Prepend[EuclideanDistance @@@ Most@#, 0]], #[[All, 1]]}],
       InterpolationOrder -> 1] & //
    (* Generate points at constant intervals. *)
    Table[#[t], {t, 0, ((n - 1)/n) len, len/n}] &] // 
  Graphics[{poly, Red, PointSize@Large, Point@#}] &]

With poly = N@RegularPolygon[{1, 0}, 1000], n = 12:

By replacing two last lines of code with this you get an animation:

Animate[Graphics[{poly, Red, PointSize@Large, Point@#[t]}], {t, 0, len}] &

Answer 4

Needs["GraphUtilities`"];

LSC[pts_, divs_] := Map[LineScaledCoordinate[pts, N @ #] &] @ Subdivide[divs]

Examples:

SeedRandom[1];

poly = RandomPolygon[10];

Graphics[{ Red , AbsolutePointSize[7], 
  Point[LSC[Append[#, First @ #] & @ poly[[1]], 10]], 
  EdgeForm[Gray], Opacity[.1], poly}]

Replace LSC[Append[#, First @ #] & @ poly[[1]], 10] with LSC[Append[#, First @ #] & @ poly[[1]], 5] to get

Plot[x Sin[3 x], {x, 0, 2 Pi}, 
 Filling -> Axis, 
 FillingStyle -> {LightRed, LightBlue},
 DisplayFunction -> 
  (Show[#, Epilog -> {Red, PointSize @ Large, 
     Point[First @ Cases[Normal@#, Line[x_] :> LSC[x, 7], All]]}] &)]