Welcome to the Monastery PerlMonks

### Polygon Creation -- Request for Algorithm Suggestions

by golux (Chaplain)
 on Nov 22, 2017 at 19:13 UTC Need Help??

golux has asked for the wisdom of the Perl Monks concerning the following question:

I'm working on a "hobby" Perl project in my spare time, where I want to take a set of points and order them so as to define the enclosing polygon. Ultimately this will be used in a web page (for shapes representing towns in different counties) presented using the <area shape="poly" coords="..."> tag.

I've abstracted what I have so far into a short test program "test.pl":

```#!/usr/bin/perl -w

###############
## Libraries ##
###############
use strict;
use warnings;
use Function::Parameters;
use lib ".";
use Shape;

##################
## Main Program ##
##################
my \$a_points = assign_points();
create_shape(\$a_points);

#################
## Subroutines ##
#################
fun create_shape(\$a_points) {
my \$shape = Shape->new(\$a_points);
\$shape->show_points("Before pruning");
\$shape->prune_interior_points;
\$shape->show_points("After pruning");
}

fun assign_points() {
return [
[527,83],[527,84],[526,84],[525,84],[524,84],[523,84],[522,84]
+,
[521,84],[520,84],[520,85],[519,85],[518,85],[518,86],[519,86]
+,
[520,86],[521,86],[522,86],[523,86],[524,86],[525,86],[526,86]
+,
[527,86],[527,85],[526,85],[525,85],[524,85],[523,85],[522,85]
+,
[521,85],[527,87],[526,87],[525,87],[524,87],[523,87],[522,87]
+,
[521,87],[520,87],[519,87],[518,87],[518,88],[517,88],[517,89]
+,
[516,89],[516,90],[515,90],[515,91],[516,91],[517,91],[518,91]
+,
[519,91],[520,91],[521,91],[522,91],[523,91],[524,91],[525,91]
+,
[526,91],[527,91],[528,91],[529,91],[530,91],[531,91],[532,91]
+,
[533,91],[534,91],[535,91],[536,91],[537,91],[537,90],[536,90]
+,
[535,90],[534,90],[533,90],[532,90],[531,90],[530,90],[529,90]
+,
[528,90],[527,90],[526,90],[525,90],[524,90],[523,90],[522,90]
+,
[521,90],[520,90],[519,90],[518,90],[517,90],[518,89],[519,89]
+,
[520,89],[521,89],[522,89],[523,89],[524,89],[525,89],[526,89]
+,
[527,89],[528,89],[529,89],[530,89],[531,89],[532,89],[533,89]
+,
[534,89],[535,89],[536,89],[537,89],[537,88],[529,88],[528,88]
+,
[527,88],[526,88],[525,88],[524,88],[523,88],[522,88],[521,88]
+,
[520,88],[519,88],[537,92],[536,92],[535,92],[534,92],[533,92]
+,
[532,92],[531,92],[530,92],[529,92],[528,92],[527,92],[526,92]
+,
[525,92],[524,92],[523,92],[522,92],[521,92],[520,92],[519,92]
+,
[518,92],[517,92],[516,92],[515,92],[515,93],[516,93],[517,93]
+,
[518,93],[519,93],[520,93],[521,93],[522,93],[523,93],[524,93]
+,
[525,93],[526,93],[527,93],[528,93],[529,93],[530,93],[531,93]
+,
[532,93],[533,93],[534,93],[535,93],[536,93],[537,93],[537,94]
+,
[536,94],[535,94],[534,94],[533,94],[532,94],[531,94],[530,94]
+,
[529,94],[528,94],[527,94],[526,94],[525,94],[524,94],[523,94]
+,
[522,94],[521,94],[520,94],[519,94],[518,94],[517,94],[516,94]
+,
[515,94],[515,95],[514,95],[513,95],[512,95],[511,95],[510,95]
+,
[509,95],[508,95],[507,95],[506,95],[505,95],[504,95],[503,95]
+,
[502,95],[501,95],[501,94],[502,94],[503,94],[504,94],[505,94]
+,
[506,94],[507,94],[508,94],[509,94],[510,94],[506,93],[505,93]
+,
[504,93],[503,93],[502,93],[501,93],[501,92],[500,92],[500,91]
+,
[499,91],[499,90],[498,90],[498,89],[499,89],[500,89],[500,90]
+,
[499,88],[501,91],[502,91],[502,92],[503,92],[504,92],[501,96]
+,
[502,96],[503,96],[504,96],[505,96],[506,96],[507,96],[508,96]
+,
[509,96],[510,96],[511,96],[512,96],[513,96],[514,96],[515,96]
+,
[516,96],[517,96],[518,96],[519,96],[520,96],[521,96],[522,96]
+,
[523,96],[524,96],[525,96],[526,96],[527,96],[528,96],[529,96]
+,
[530,96],[531,96],[532,96],[533,96],[534,96],[535,96],[536,96]
+,
[537,96],[537,95],[536,95],[535,95],[534,95],[533,95],[532,95]
+,
[531,95],[530,95],[529,95],[528,95],[527,95],[526,95],[525,95]
+,
[524,95],[523,95],[522,95],[521,95],[520,95],[519,95],[518,95]
+,
[517,95],[516,95],[537,97],[536,97],[535,97],[534,97],[533,97]
+,
[532,97],[531,97],[530,97],[529,97],[528,97],[527,97],[526,97]
+,
[525,97],[524,97],[523,97],[522,97],[521,97],[520,97],[519,97]
+,
[518,97],[517,97],[516,97],[515,97],[514,97],[513,97],[512,97]
+,
[511,97],[510,97],[509,97],[508,97],[507,97],[506,97],[505,97]
+,
[504,97],[503,97],[502,97],[501,97],[504,98],[505,98],[506,98]
+,
[507,98],[508,98],[509,98],[510,98],[511,98],[512,98],[513,98]
+,
[514,98],[515,98],[516,98],[517,98],[518,98],[519,98],[520,98]
+,
[521,98],[522,98],[523,98],[524,98],[525,98],[526,98],[527,98]
+,
[528,98],[529,98],[530,98],[531,98],[532,98],[533,98],[534,98]
+,
[535,98],[536,98],[537,98],[537,99],[536,99],[535,99],[534,99]
+,
[533,99],[532,99],[531,99],[530,99],[529,99],[528,99],[527,99]
+,
[526,99],[525,99],[524,99],[523,99],[522,99],[521,99],[520,99]
+,
[519,99],[518,99],[517,99],[516,99],[515,99],[514,99],[513,99]
+,
[512,99],[511,99],[510,99],[509,99],[508,99],[507,99],[506,99]
+,
[505,99],[504,99],[504,100],[505,100],[506,100],[507,100],[508
+,100],
[509,100],[510,100],[511,100],[512,100],[513,100],[514,100],[5
+15,100],
[516,100],[517,100],[518,100],[519,100],[520,100],[521,100],[5
+22,100],
[523,100],[524,100],[525,100],[526,100],[527,100],[528,100],[5
+29,100],
[530,100],[531,100],[532,100],[533,100],[534,100],[535,100],[5
+36,100],
[537,100],[537,101],[536,101],[535,101],[534,101],[533,101],[5
+32,101],
[531,101],[530,101],[529,101],[528,101],[527,101],[526,101],[5
+25,101],
[524,101],[523,101],[522,101],[521,101],[520,101],[519,101],[5
+18,101],
[517,101],[516,101],[515,101],[514,101],[513,101],[512,101],[5
+11,101],
[510,101],[509,101],[508,101],[507,101],[506,101],[505,101],[5
+05,102],
[506,102],[507,102],[508,102],[509,102],[510,102],[511,102],[5
+12,102],
[513,102],[514,102],[515,102],[516,102],[517,102],[518,102],[5
+19,102],
[520,102],[521,102],[522,102],[523,102],[524,102],[525,102],[5
+26,102],
[527,102],[528,102],[529,102],[530,102],[531,102],[532,102],[5
+33,102],
[534,102],[535,102],[536,102],[537,102],[537,103],[536,103],[5
+35,103],
[534,103],[533,103],[532,103],[531,103],[530,103],[529,103],[5
+28,103],
[527,103],[526,103],[525,103],[524,103],[523,103],[522,103],[5
+21,103],
[520,103],[519,103],[518,103],[517,103],[516,103],[515,103],[5
+14,103],
[513,103],[512,103],[511,103],[510,103],[509,103],[508,103],[5
+07,103],
[506,103],[505,103],[506,104],[507,104],[508,104],[509,104],[5
+10,104],
[511,104],[512,104],[513,104],[514,104],[515,104],[516,104],[5
+17,104],
[518,104],[519,104],[520,104],[521,104],[522,104],[523,104],[5
+24,104],
[525,104],[526,104],[527,104],[528,104],[529,104],[530,104],[5
+31,104],
[532,104],[533,104],[534,104],[535,104],[536,104],[537,104],[5
+37,105],
[536,105],[535,105],[534,105],[533,105],[532,105],[531,105],[5
+30,105],
[529,105],[528,105],[527,105],[526,105],[525,105],[524,105],[5
+23,105],
[522,105],[521,105],[520,105],[519,105],[518,105],[517,105],[5
+16,105],
[515,105],[514,105],[513,105],[512,105],[511,105],[510,105],[5
+09,105],
[508,105],[507,105],[506,105],[506,106],[507,106],[508,106],[5
+09,106],
[510,106],[511,106],[512,106],[513,106],[514,106],[515,106],[5
+16,106],
[517,106],[518,106],[519,106],[520,106],[521,106],[522,106],[5
+23,106],
[524,106],[525,106],[526,106],[527,106],[528,106],[529,106],[5
+30,106],
[531,106],[532,106],[533,106],[534,106],[535,106],[536,106],[5
+37,106],
[536,107],[535,107],[534,107],[533,107],[532,107],[531,107],[5
+30,107],
[529,107],[528,107],[527,107],[526,107],[525,107],[524,107],[5
+23,107],
[522,107],[521,107],[520,107],[519,107],[518,107],[517,107],[5
+16,107],
[515,107],[514,107],[513,107],[512,107],[511,107],[510,107],[5
+09,107],
[508,107],[507,107],[508,108],[509,108],[510,108],[511,108],[5
+12,108],
[513,108],[514,108],[515,108],[516,108],[517,108],[518,108],[5
+19,108],
[520,108],[521,108],[522,108],[523,108],[524,108],[525,108],[5
+26,108],
[527,108],[528,108],[529,108],[530,108],[531,108],[532,108],[5
+33,108],
[534,108],[535,108],[536,108],[536,109],[535,109],[534,109],[5
+33,109],
[532,109],[531,109],[530,109],[529,109],[528,109],[527,109],[5
+26,109],
[525,109],[524,109],[523,109],[522,109],[521,109],[520,109],[5
+19,109],
[518,109],[517,109],[516,109],[515,109],[514,109],[513,109],[5
+20,110],
[521,110],[522,110],[523,110],[524,110],[525,110],[526,110],[5
+27,110],
[528,110],[529,110],[530,110],[531,110],[532,110],[533,110],[5
+34,110],
[535,110],[536,110],[536,111],[535,111],[534,111],[533,111],[5
+32,111],
[531,111],[530,111],[529,111],[528,111],[527,111],[526,111],[5
+25,111],
[524,111],[530,112],[531,112],[532,112],[533,112],[534,112],[5
+35,112],
[534,113],[533,113],[532,113],[531,113],[530,113],
];
}
and a corresponding module "Shape.pm":
```package Shape;

#=============#
## Libraries ##
#=============#
use strict;
use warnings;
use feature qw( say );
use Data::Dumper::Concise;
use Function::Parameters;

#===============#
## Constructor ##
#===============#
method new(\$proto: \$a_points = [ ]) {
my \$self = { points => \$a_points };
bless \$self, \$proto;
return \$self;
}

#==================#
## Public methods ##
#==================#
#
#  points()
#
#  Returns the underlying points data
#
method points() { return \$self->{points} }

#
#
#  Adds a point to the shape, in the format [ \$x, \$y ].
#
#
my \$a_points = \$self->points;
push @\$a_points, \$a_point;
}

#  prune_interior_points()
#
#  Removes points within the interior of the shape.
#
#  Such points are defined as being bordered on all 4 sides
#  (excluding diagonals) by other points in the shape.
#
#  For example, the points '#' in the shape on the left would be
#  pruned to produce the shape on the right (where 'o' stands for
#  a point which has been pruned, so is actually no longer present
#  in the shape):
#
#      . . . . . . . . . . . .        . . . . . . . . . . . .
#      . . . # . . . . . . . .        . . . # . . . . . . . .
#      . . # # # . . . . . . .        . . # o # . . . . . . .
#      . . . # # # # # # # # .        . . . # o # # # # # # .
#      . . # # # # # # # # . .        . . # o o o o o o # . .
#      . # # # # # # # # . . .        . # # o o o o o # . . .
#      . . . # # # # # # # # .        . . . # o o o o o # # .
#      . . . . # # # # # . . .        . . . . # # # # # . . .
#      . . . . . . . . # # . .        . . . . . . . . # # . .
#      . . . . . . . . . . . .        . . . . . . . . . . . .
#
method prune_interior_points() {
my \$a_pruned = [ ];

my \$a_points = \$self->points;

for (my \$i = 0; \$i < @\$a_points; \$i++) {
my \$a_pt = \$a_points->[\$i];
my (\$x, \$y) = @\$a_pt;
if (!\$self->_point_is_surrounded(\$x, \$y, \$a_points)) {
push @\$a_pruned, [ \$x, \$y ];
}
}

return \$self->{points} = \$a_pruned;
}

#
#  show_points()
#
#  Creates a simple ascii display of the points in the shape
#
method show_points(\$label = "Shape") {
my \$a_points = \$self->points;
my (\$minx, \$miny, \$maxx, \$maxy) = \$self->_find_extrema();
my \$width  = \$maxx - \$minx + 1;
my \$height = \$maxy - \$miny + 1;
my \$N      = @\$a_points;

say "\n[\$label: \$N points]";

# Create a blank shape
my \$shape = [ ];
for (my \$y = 0; \$y < \$height + 2; \$y++) {
my \$row = \$shape->[\$y] = [ ];
for (my \$x = 0; \$x < \$width + 2; \$x++) {
\$row->[\$x] = 0;
}
}

# Fill in the points for the current shape
for (my \$i = 0; \$i < @\$a_points; \$i++) {
my \$a_point = \$a_points->[\$i];
my (\$x, \$y) = @\$a_point;
\$y = \$y - \$miny + 1;
\$x = \$x - \$minx + 1;
my \$row    = \$shape->[\$y];
\$row->[\$x] = 1;
}

# Display the resulting shape
for (my \$y = 0; \$y < \$height + 2; \$y++) {
my \$row  = \$shape->[\$y];
my \$line = join("", map { \$_? '#': '.' } @\$row);
say \$line;
}
}

#===================#
## Private methods ##
#===================#
method _fatal(\$msg) {
my \$lnum = (caller)[2];
die "(Shape.pm) FATAL[\$lnum]:  \$msg\n";
}

#
#  _point_is_surrounded(\$x, \$y, \$a_points)
#
#  Given a point (\$x, \$y), returns nonzero iff that point is bounded
#  on all 4 sides (excluding diagonals) by other points.
#
method _point_is_surrounded(\$x, \$y, \$a_points = \$self->points) {
my \$nneighbors = 0;

for (my \$i = 0; \$i < @\$a_points; \$i++) {
my \$a_pt = \$a_points->[\$i];
my (\$x1, \$y1) = @\$a_pt;
my \$dx = abs(\$x1 - \$x);
my \$dy = abs(\$y1 - \$y);
if ((1 == \$dx and 0 == \$dy) or (0 == \$dx and 1 == \$dy)) {
++\$nneighbors;
}
}

return (4 == \$nneighbors)? 1: 0;
}

#
#  _find_extrema
#
#  Returns the bounding box, represented by the MIN (X, Y) and MAX (X,
+ Y)
#  points for the shape.
#
method _find_extrema() {
my \$a_points = \$self->points;
my (\$minx, \$miny, \$maxx, \$maxy);

for (my \$i = 0; \$i < @\$a_points; \$i++) {
my (\$x, \$y) = @{\$a_points->[\$i]};
defined(\$x) or \$self->_fatal("Undefined X");
defined(\$y) or \$self->_fatal("Undefined Y");

if (0 == \$i) {
\$minx = \$maxx = \$x;
\$miny = \$maxy = \$y;
}

(\$x < \$minx) and \$minx = \$x;
(\$y < \$miny) and \$miny = \$y;
(\$x > \$maxx) and \$maxx = \$x;
(\$y > \$maxy) and \$maxy = \$y;
}

return ( \$minx, \$miny, \$maxx, \$maxy );
}
I'm happy with my prune_interior_points method, which takes the initial set of points and discards all but the outline of the shape (both of which you can see by running the script "test.pl".

The final step will be to order the points in such a way that no two consecutive points have too much distance between them, but still using ALL of the points, so as to produce a polygon. The distance algorithm for any two points is, of course, sqrt((\$y1 - \$y0) ** 2 + sqrt(\$x1 - \$x0) ** 2), but I'm getting stuck on finding a simple algorthm for producing this ordering.

Does anyone have any suggestions for such an algorithm?

Edit: It occurs I could have made this a Meditation, since it's more about discussing algorithms than it is about a specific Perl question.

say  substr+lc crypt(qw \$i3 SI\$),4,5

Replies are listed 'Best First'.
Re: Polygon Creation -- Request for Algorithm Suggestions
by tybalt89 (Prior) on Nov 23, 2017 at 07:51 UTC

Here's an attempt using strings ( so I can do "inner" point removal with just one s/// ) and using vr's triple idea Re: Polygon Creation -- Request for Algorithm Suggestions ( so I can "walk" the perimeter by finding the closest unused point to the previous point.

```#!/usr/bin/perl

# http://perlmonks.org/?node_id=1204060

use strict;
use warnings;

my @points = points();
my (\$minx, \$miny, \$maxx, \$maxy) = (
\$points[0][0], \$points[0][1], \$points[0][0], \$points[0][1]);

for (@points)
{
my (\$x, \$y) = @\$_;
\$minx > \$x and \$minx = \$x;
\$miny > \$y and \$miny = \$y;
\$maxx < \$x and \$maxx = \$x;
\$maxy < \$y and \$maxy = \$y;
}

my \$width = \$maxx - \$minx + 1;
my \$width3 = \$width * 3;
my \$gridwidth = \$width3 + 1;
my \$height = \$maxy - \$miny + 1;
my @letters = ('A' .. 'Z', 'a' .. 'z'); # label points by letter seque
+nce

my \$grid = ( '---' x \$width . "\n" ) x \$height x 3;

for (@points)
{
my (\$x, \$y) = @\$_;
for my \$xx (0..2) # triple
{
for my \$yy (0..2) # triple
{
substr \$grid,
((\$y - \$miny) * 3 + \$yy) * \$gridwidth + (\$x - \$minx) * 3 + \$xx
+,
1, 'O';
}
}
}

#print \$grid, "\n\n";

\$grid =~ s/          # remove "inside" points
(?<=O)
(?<=O.{\$width3})
O
(?=O)
(?=.{\$width3}O)
/ /gsx;

#print \$grid, "\n";

my \$output = (' ' x \$width . "\n") x \$height;

my \$i = 0;
my @available;

push @available, \$-[0] while \$grid =~ /O/g;
my \$previous = shift @available;
place(\$previous);

while( @available )
{
(my \$closest, @available) = map \$_->[0],
sort { \$a->[1] <=> \$b->[1] }
map [ \$_, distance(\$_, \$previous) ],
@available;
\$previous = \$closest;
place(\$closest);
}

print "\$output\n"; # for show

sub place
{
my \$pos3 = shift;
my (\$x3, \$y3) = ( \$pos3 % \$gridwidth, int \$pos3 / \$gridwidth );
my (\$x, \$y) = (int \$x3 / 3, int \$y3 / 3);
pos(\$output) = \$y * (\$width + 1) + \$x;
\$output =~ s/\G /\$letters[\$i++ % @letters]/ and
push @answerpoints, [ \$x + \$minx, \$y + \$miny ];
}

sub distance # between two pos values
{
my (\$from, \$to) = @_;
my (\$x1, \$y1) = ( \$from % \$gridwidth, int \$from / \$gridwidth );
my (\$x2, \$y2) = ( \$to % \$gridwidth, int \$to / \$gridwidth );
sqrt( (\$x2 - \$x1)**2 + (\$y2 - \$y1)**2 ); # sqrt may not be needed
}

sub points
{
... data points removed to shorten listing
}

Outputs (using letters in sequence to show the order of the points):

```                             A
MNOPQRSB
KL       C
J        D
I        E
k                 H          FG       O
j l               G             HIJKLMNP
i m              F                     Q
h no            E                     R
g  pq          D                     S
f   rs        C                     T
e     tuvw    B                     U
d         xyzA                      V
c                                   W
baZ                                 X
Y                                Y
X                                Z
W                                a
V                               b
U                               c
T                               d
S                              e
R                              f
Q                              g
P                            h
ONMLK                       i
JIHGFED                j
CBAz            k
yxwvut      l
s    m
rqpon

Of course, the "real" answer is in @answerpoints (not shown because of length)

Re: Polygon Creation -- Request for Algorithm Suggestions
by LanX (Cardinal) on Nov 22, 2017 at 23:30 UTC
From the bottom of my mind:

The simplest algorithm I'm aware of is to successively

• construct the smallest polygon enclosing n-1 points
• check if point n is inside the polygon
• if YES then it's already the smallest polygon enclosing n points
• if NO then include it as a new corner
You have to start with a triangle and finish with the smallest convex hull.

The check is crucial, you need a scalar product of the point vector with orthogonal vectors on all edges pointing inside.

If the product is positiv it means the point is "inside" the edge.

Iff the point is inside all edges, it's inside the polygon.

Otherwise you extend the polygon by replacing all "outside" edges.

(Most probably you'll also need to move the points before doing the product, such that the edge goes thru (0,0) )

HTH and you get the idea.

I'm pretty tired, lacking the right vocabulary and typing into my mobile without possibility to scetch it on paper. :)

Cheers Rolf
(addicted to the Perl Programming Language and ☆☆☆☆ :)
Wikisyntax for the Monastery

Thanks, LanX,

I agree with you that what I want is a "smallest convex hull". I'll see if I can get my head around the math involved.

say  substr+lc crypt(qw \$i3 SI\$),4,5
> I agree with you that what I want is a "smallest convex hull".

Looking at the other answers I'm not sure anymore. A convex hull means a banana shape would be represented as a semicircle.

You seem to want a tight (not necessarily convex) vector graphic enclosing a sprite.

I think you could achieve this by improving the convex hull (by replacing long edges with concave triangles until all edges are sufficiently "short" or "tight")

Another problem I see are non-connected segments/territories . The shape of the USA would look very different if Alaska and Hawaii were included into just one hull ...

##### update

Pointing to the next problem There is no unique solution for a concave polygon

So starting from a convex hull and improving it till criteria are met is sensible.

Cheers Rolf
(addicted to the Perl Programming Language and ☆☆☆☆ :)
Wikisyntax for the Monastery

I can't post images here but I came around this wikipedia article which should be of help understanding how the do product helps identifying distance and orientation of a point in respect to an edge Scalar_projection

Cheers Rolf
(addicted to the Perl Programming Language and ☆☆☆☆ :)
Wikisyntax for the Monastery

##### update

Re: Polygon Creation -- Request for Algorithm Suggestions
by tybalt89 (Prior) on Nov 26, 2017 at 17:38 UTC

I wanted to see what an edge walker looked like in the "strings/regex" domain...

```#!/usr/bin/perl

# http://perlmonks.org/?node_id=1204060

use strict;
use warnings;

my @points = points();
my (\$minx, \$miny, \$maxx, \$maxy) = (
\$points[0][0], \$points[0][1], \$points[0][0], \$points[0][1]);

for (@points)
{
my (\$x, \$y) = @\$_;
\$minx > \$x and \$minx = \$x;
\$miny > \$y and \$miny = \$y;
\$maxx < \$x and \$maxx = \$x;
\$maxy < \$y and \$maxy = \$y;
}

my \$height = \$maxy - \$miny + 3;  # some useful stuff
my \$width = \$maxx - \$minx + 3;
my \$gw = \$width + 1; # grid width (distance to down one row)
my \$gwm3 = \$gw - 3;
my @letters = ('A' .. 'Z', 'a' .. 'z'); # label points by letter seque
+nce
my @steps = (1, \$gw+1, \$gw, \$gw-1, -1, -\$gw-1, -\$gw, -\$gw+1); # by dir
+ection
my \$grid = ( ' ' x \$width . "\n" ) x \$height;
my @answerpoints; # coordinates around edge

for (@points) # put points on grid (multiline string :)
{
my (\$x, \$y) = @\$_;
substr \$grid, ((\$y - \$miny + 1)) * \$gw + (\$x - \$minx + 1), 1, '#';
}

my \$direction = 0; # start facing east (increases clockwise)
my \$start = my \$at = \$grid =~ /(?<= )#/ ? \$-[0] : die "empty"; # at to
+pleft

do # clockwise walk around edge
{
push @answerpoints, [ \$at % \$gw - 1 + \$minx, int \$at / \$gw - 1 + \$mi
+ny ];
pos(\$grid) = \$at - \$gw - 1; # northwest corner neighbor
\$grid =~ /\G(.)(.)(.).{\$gwm3}(.).(.).{\$gwm3}(.)(.)(.)/s; # all neigh
+bors
("\$1\$2\$3\$5\$8\$7\$6\$4" x 2) =~ /^.{\$direction} *(#)/ and # rotate & sca
+n
\$at += \$steps[ \$direction = ( \$-[1] - 3 ) % 8 ]; # step in new dir
+ection
}
until( \$at == \$start );

my \$i = 0;
{
my (\$x, \$y) = @\$_;
pos(\$grid) = \$x - \$minx + 1 + (\$y - \$miny + 1) * \$gw;
\$grid =~ s/\G#/\$letters[\$i++ % @letters]/; # label point if not
}
print \$grid;

sub points
{
[527,83],[527,84],[526,84],[525,84],[524,84],[523,84],[522,84],
... some points deleted to shorten listing ...
[534,113],[533,113],[532,113],[531,113],[530,113],
}

Outputs:

```                              A
MNOPQRSB
KL#######C
J########D
I########E
k                 H##########FG       O
j#l               G#############HIJKLMNP
i#m              F#####################Q
h#no            E#####################R
g##pq          D#####################S
f###rs        C#####################T
e#####tuvw    B#####################U
d#########xyzA######################V
c###################################W
baZ#################################X
Y################################Y
X################################Z
W################################a
V###############################b
U###############################c
T###############################d
S##############################e
R##############################f
Q##############################g
P############################h
ONMLK#######################i
JIHGFED################j
CBAz############k
yxwvut######l
s####m
rqpon

Sure saves a lot of that ugly subscripting :)

UPDATE: New and Improved!! Now with Tk!! see Re^2: Polygon Creation -- Request for Algorithm Suggestions

New and Improved! Now with Tk !!

```#!/usr/bin/perl

# http://perlmonks.org/?node_id=1204060

use strict;
use warnings;

my @points = points();

#@points = map [int rand 27, int rand 25 ], 1..700; # random test case

my (\$minx, \$miny, \$maxx, \$maxy) = (
\$points[0][0], \$points[0][1], \$points[0][0], \$points[0][1]);

for (@points)
{
my (\$x, \$y) = @\$_;
\$minx > \$x and \$minx = \$x;
\$miny > \$y and \$miny = \$y;
\$maxx < \$x and \$maxx = \$x;
\$maxy < \$y and \$maxy = \$y;
}

my \$height = \$maxy - \$miny + 3;  # some useful stuff
my \$width = \$maxx - \$minx + 3;
my \$gw = \$width + 1; # grid width (distance to down one row)
my \$gwm3 = \$gw - 3;
my @letters = ('A' .. 'Z', 'a' .. 'z'); # label points by letter seque
+nce
my @steps = (1, \$gw+1, \$gw, \$gw-1, -1, -\$gw-1, -\$gw, -\$gw+1); # by dir
+ection
my \$grid = ( ' ' x \$width . "\n" ) x \$height;

for (@points) # put points on grid (multiline string :)
{
my (\$x, \$y) = @\$_;
substr \$grid, ((\$y - \$miny + 1)) * \$gw + (\$x - \$minx + 1), 1, '#';
}

while( \$^R = 0,                     # reset, find valid starting point
\$grid =~ /(?<=   .{\$gwm3} )#(?= .{\$gwm3} . )/s # top end - spikes
or \$grid =~ /(?<=   .{\$gwm3} )#(?=..{\$gwm3}   )/s # left end
or \$grid =~ /(?<=   .{\$gwm3}.)#(?= .{\$gwm3}   )/s # right end
or \$grid =~ /(?<= . .{\$gwm3} )#(?= .{\$gwm3}   )/s # bottom end
or \$grid =~ /(?<=   .{\$gwm3} )#(?= .{\$gwm3}(  #|#  ))/s # ul | ur en
+d
or \$grid =~ /(?<=(#  |  #).{\$gwm3} )#(?= .{\$gwm3}   )/s # ll | lr en
+d

or \$grid =~ /(?<=   .{\$gwm3} )#(?=#.{\$gwm3}(.#|  #))/s # top left
or \$grid =~ /(?<=   .{\$gwm3}#)#(?= .{\$gwm3}(#| #))/s # top right
or \$grid =~ /(?<=(.#.|  #).{\$gwm3} )#(?=#.{\$gwm3}   )(?{4})/s # bott
+om left
or \$grid =~ /(?<=(.#.|#..).{\$gwm3}#)#(?= .{\$gwm3}   )(?{4})/s # bott
+om right
)
{
my \$direction = \$^R; # 0 is east (increases clockwise)
my @answerpoints; # coordinates around edge
my \$start = my \$at = \$-[0]; # at topleft

do # clockwise walk around edge
{
push @answerpoints, [ \$at % \$gw - 1 + \$minx, int \$at / \$gw - 1 + \$
+miny ];
pos(\$grid) = \$at - \$gw - 1; # northwest corner neighbor
\$grid =~ /\G(.)(.)(.).{\$gwm3}(.).(.).{\$gwm3}(.)(.)(.)/s; # all nei
+ghbors
\$at += ("\$1\$2\$3\$5\$8\$7\$6\$4" x 2) =~ /^.{\$direction} *(#)/ # rotate
+& scan
? \$steps[ \$direction = ( \$-[1] - 3 ) % 8 ] # step in new directi
+on
: \$start - \$at; # force loop exit because scan failed
}
until( \$at == \$start );

my \$i = 0;
{
my (\$x, \$y) = @\$_;
pos(\$grid) = \$x - \$minx + 1 + (\$y - \$miny + 1) * \$gw;
\$grid =~ s/\G#/\$letters[\$i++ % @letters]/; # label point if not
}
print \$grid;

}

sub draw
{
use Tk;
my \$size = 700;
my @pts = map { (\$_->[0] - \$minx + 1) * \$size / \$gw + 1,
(\$_->[1] - \$miny + 1) * \$size / (\$maxy - \$miny + 2) + 1 } @_;
@pts > 50 or return;
my \$mw = MainWindow->new;
\$mw->geometry('+600+2');
my \$c = \$mw->Canvas(-width => \$size, -height => \$size)->pack;
\$c->createPolygon(@pts, -fill => 'green',
-width => 7, -outline => 'black');
\$c->createOval(\$pts[0] - 10, \$pts[1] - 10, \$pts[0] + 10, \$pts[1] + 1
+0);
\$mw->Button(-text => 'Exit', -command => sub {\$mw->destroy},
)->pack(-fill => 'x', -expand => 1);
MainLoop;
}

sub points
{
[527,83],[527,84],[526,84],[525,84],[524,84],[523,84],[522,84],
... some points not shown to shorten listing ...
[534,113],[533,113],[532,113],[531,113],[530,113],
}

Very neat! I'll have to study it and see how it works. I've had to put in a few more bounds-checks in mine to remove some problems, adding even more annoying subscripts...

...roboticus

When your only tool is a hammer, all problems look like your thumb.

Re: Polygon Creation -- Request for Algorithm Suggestions
by vr (Curate) on Nov 23, 2017 at 01:03 UTC

Well, it's too late/early today for any code (sorry), perhaps tomorrow if it won't look too stupid in the morning, and it appears like roboticus knows much better, but I started with this answer before his, so FWIW:

0. Slightly modify your algorithm to eliminate corner points (see below why).

1. Starting with original image, triple it, i.e. each pixel (point).

Original fragment:

```# # # # .
# # # . .
# # . . .
# # # # .
# # . . .
```

```# # # # .
o o # . .
o # . . .
o o # # .
# # . . .
```

Original was tripled, algorithm applied (corners eliminated),

```###########.
...........#
.........##.
..#
..#
.##.
..#
..#
..#
......#####.
...........#
......#####.
..#
..#
#####.
```

So, now every marked pixel is guaranteed to have only 2 neighbours.

4. Then it's trivial to start anywhere and just pick unused neighbour until polyline closed.

5. Scale polyline to original (integer division?).

6. Reduce it to eliminate same points as begin-end.

Here's some code. It occurred to me, that algorithm eliminating shape interior, in original post by golux, is actually simple kernel convolution in 2D, rolled out manually. Because of that, and because I don't like the idea of manipulating points one by one, I decided to process them "en masse", starting from original "image".

It looks like Imager can only do 1D convolution, PerlMagick is in somewhat sad state. So it's back to PDL again.

I tried to invent a kernel that would allow both to eliminate interior and to "round" corners in one pass, but unsuccessfully. Further, I couldn't invent such 2nd kernel, so that only one (instead of 2) comparison is required afterwards.

Interesting: walking direction along the outline happened to be counter-clockwise. Perhaps algorithm can be improved to allow to choose direction, from starting point.

```use strict;
use warnings;
use feature    qw/ say /;
use List::Util qw/ first uniqnum /;
use PDL;
use PDL::Image2D;

# It's important that shape doesn't touch boundaries.
# Otherwise neighbours could be found across image edges,
# or substr (below) can look outside argument.

my ( \$w, \$h ) = ( 42, 33 );
my \$str = << 'END';
..........................................
..............................#...........
.......................########...........
.....................##########...........
.....................##########...........
.....................##########...........
..#.................#############.......#.
.###...............######################.
.###..............#######################.
..####............#######################.
...#####..........#######################.
....######........#######################.
....##########....#######################.
....#####################################.
....#####################################.
....#####################################.
.......##################################.
.......##################################.
.......##################################.
........#################################.
........#################################.
........#################################.
.........################################.
.........################################.
.........################################.
..........##############################..
...........#############################..
................########################..
.......................#################..
...........................#############..
.................................######...
.................................#####....
..........................................
END
\$str =~ tr/.#\n/01/d;

my ( \$w_, \$h_ ) = ( 3 * \$w, 3 * \$h );
my \$in  = pdl([ split '', \$str ])-> reshape( \$w, \$h );
my \$img = zeroes( \$w_, \$h_ );
rescale2d( \$in, \$img );

my \$kernel_1 = pdl([ qw/
0 -1  0
-1  4 -1
0 -1  0
/])-> reshape( 3, 3 );

my \$kernel_2 = pdl([ qw/
0 -2  0
-1  5 -1
0 -2  0
/])-> reshape( 3, 3 );

\$img = conv2d( \$img, \$kernel_1 ) > 0;
\$img = conv2d( \$img, \$kernel_2 );
\$img = ( \$img == 1 ) + ( \$img >= 3 );

# Dump image any time for inspection,
# terminal must be wider than \$w_ (126).
#
# my @lst = \$img-> list;
# say splice @lst, 0, \$w_ while @lst;

# Back to Perl from PDL-land.

my \$s = \${ \$img-> byte-> get_dataref };

my @checks = (                  # 8 neighbours
-\$w_ - 1,  -\$w_, -\$w_ + 1,
-1,               1,
\$w_ - 1,   \$w_,  \$w_ + 1,
);

my \$i = CORE::index \$s, "\1";   # 1st point
my @list = ( \$i );
substr \$s, \$i, 1, "\0";

while () {
my \$j = first { "\1" eq substr \$s, \$i + \$_, 1 } @checks;
last unless defined \$j;
\$i += \$j;
push @list, \$i;
substr \$s, \$i, 1, "\0";
}

die if CORE::index( \$s, "\1" ) >= 0;        # can't be

# Scale point coordinates back to original,
# squash duplicates.

@list = uniqnum map {
use integer;
my \$x = \$_ % \$w_ / 3;
my \$y = \$_ / \$w_ / 3;
\$x + \$y * \$w
} @list;

# @list uniquely identifies sequence to create polyline,
# can be converted to (x,y) pairs if required.
# Below is simple transformation to 2D picture.

my \$out = '.' x ( \$w * \$h );
my \$n   = 0;
for ( @list ) {
substr \$out, \$_, 1, \$n ++;
\$n %= 10;
}
say substr \$out, 0, \$w, '' while \$out;

And then:

```..........................................
..............................0...........
.......................76543212...........
.....................98.......1...........
.....................0........0...........
.....................1........9...........
..5.................2..........87.......9.
.6.4...............3.............65432108.
.7.3..............4.....................7.
..8.21............5.....................6.
...9..09..........6.....................5.
....0...87........7.....................4.
....1.....6543....8.....................3.
....2.........2109......................2.
....3...................................1.
....456.................................0.
.......7................................9.
.......8................................8.
.......9................................7.
........0...............................6.
........1...............................5.
........2...............................4.
.........3..............................3.
.........4..............................2.
.........5..............................1.
..........6............................0..
...........78901.......................9..
................2345678................8..
.......................9012............7..
...........................345678......6..
.................................9....5...
.................................01234....
..........................................

P.S. And isn't it great that regex engine has finally a day off?

Update. Damn... Of course 2nd convolution and kernel weren't necessary. Convex corners are "2"s after the 1st one. A replacement for fragment from applying a kernel till die statement, with other (I hope so) improvements:

```\$img  = conv2d( \$img, \$kernel ) == 1;
\$img += 48;

my \$s = \${ \$img-> byte-> get_dataref };

my @checks = (              # increments to
-\$w_ - 1 ,1, 1,             # 8 neighbours
\$w_ - 2,    2,
\$w_ - 2, 1, 1,
);

my \$i = CORE::index \$s, 1;  # 1st point
my @list = ( \$i );
substr \$s, \$i, 1, 0;

push @list, \$i
while first { substr \$s, \$i += \$_, 1, 0 } @checks;

Update 2. Oh, DAMN... What a frustration. The uniqnum description says:

Filters a list of values to remove subsequent duplicates

(emphasis mine), and I didn't test it.

```>perl -MList::Util=uniqnum -E "say for uniqnum 1,1,2,1
1
2

Ah? I thought, like:

```>perl -E "say '1121'=~tr/12/12/sr"
121

Then, are any duplicates removed? Why wasting time on word "subsequent"? Part of my code to be replaced, uniqnum dumped for good, core module or not:

```my \$prev = -1;
@list = grep {
my \$res = \$prev != \$_;
\$prev = \$_;
\$res
} map {
use integer;
my \$x = \$_ % \$w_ / 3;
my \$y = \$_ / \$w_ / 3;
\$x + \$y * \$w
} @list;

damn...

Re: Polygon Creation -- Request for Algorithm Suggestions
by eyepopslikeamosquito (Bishop) on Nov 27, 2017 at 03:14 UTC

Ultimately this will be used in a web page (for shapes representing towns in different counties)

Interesting. Many years ago, I developed Acme::EyeDrops -- which similarly had to solve the problem of how to represent arbitrary shapes for use in ascii art. If you look at Acme::EyeDrops Shape Reference, you'll see it defines two kinds of shapes:

• Built-in shapes. An algorithm is used to generate these types of shapes, for example a Sierpinski triangle. (Note that A::E has precious few built-in shapes; ideas for new built-in shapes welcome).
• ".eye file" shapes. These shapes are defined by a (simply formatted) .eye file, for example, a map of italy.

Two simple examples to give you a feel for how this works.

Running this program:

```use Acme::EyeDrops qw(sightly);
print sightly({ Text            => 1,
TextFiller      => '/\\',
Shape           => 'siertri',
# For 'siertri' built-in shape, Width=>5 means:
#   height is 2**5 lines
#   width  is 2 * 2**5 characters
Width           => 5 });
displays:
```                               /\
/\/\
/\  /\
/\/\/\/\
/\      /\
/\/\    /\/\
/\  /\  /\  /\
/\/\/\/\/\/\/\/\
/\              /\
/\/\            /\/\
/\  /\          /\  /\
/\/\/\/\        /\/\/\/\
/\      /\      /\      /\
/\/\    /\/\    /\/\    /\/\
/\  /\  /\  /\  /\  /\  /\  /\
/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
/\                              /\
/\/\                            /\/\
/\  /\                          /\  /\
/\/\/\/\                        /\/\/\/\
/\      /\                      /\      /\
/\/\    /\/\                    /\/\    /\/\
/\  /\  /\  /\                  /\  /\  /\  /\
/\/\/\/\/\/\/\/\                /\/\/\/\/\/\/\/\
/\              /\              /\              /\
/\/\            /\/\            /\/\            /\/\
/\  /\          /\  /\          /\  /\          /\  /\
/\/\/\/\        /\/\/\/\        /\/\/\/\        /\/\/\/\
/\      /\      /\      /\      /\      /\      /\      /\
/\/\    /\/\    /\/\    /\/\    /\/\    /\/\    /\/\    /\/\
/\  /\  /\  /\  /\  /\  /\  /\  /\  /\  /\  /\  /\  /\  /\  /\
/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

Running this program:

```use Acme::EyeDrops qw(sightly);
print sightly({ Text            => 1,
TextFiller      => 'Azzurri',
Shape           => 'map_italy' });
displays:
```                       Azzurr
iAzzurriAzz
urriAzzurriAzzurr
iA   zzurriAzzurriAzzurriAzz
urriAzzurriAzzurriAzzurriAzzur
riAzzurriAzzurriAzzurriAzzurriAzz
urriAzzurriAzzurriAzzurriAzzur
riAzzurriAzzurriAzzurriAzzurr
iAzzurriAzzurriAzzurriAzzurriA
zzurriAzzurriAzzurriAzzurriAzzu
rriAzzurriAzzurriAzzurriAzzurr
iAzzurr    iAzzurriAzzurri
Azzu        rriAzzurriAzzu
rr           iAzzurriAzzurri
AzzurriAzzurriAzz
urriAzzurriAzzurr
iAzzurriAzzurriAzz
u     rriAzzurriAzzurriA
zzur       riAzzurriAzzurriA
zzurr         iAzzurriAzzurriAz
zurri           AzzurriAzzurriAzz
urriA             zzurriAzzurriAzzurriA
zzu                rriAzzurriAzzurriA
zzurriAzzurriAzzur
ri                     AzzurriAzzurriAzz
urriAzzu                      rriAzzurriAzzurriA
zzurriAz                        zurriAzzurriAzzurri
Azzurri                          AzzurriAzzu  rriAz
zurriAz                            zurriAzz      urr
iAzzurr                               iAzz        ur
riAzzur                                riA
zzurriA                                zzurr
iAzz ur                                 riAzz
ur                                     riAzz
urri
Azzu
r ri          Azzur
riAzzurriAzzurri Az
zurriAzzurriAzz
urriAzzurri
AzzurriA
zzurr
iAz

The primary purpose of Acme::EyeDrops is to auto-generate obfuscated, working Perl code ... so its shape pouring capabilities are fairly primitive. I'm just bringing it to your attention in case it gives you ideas for your current project, or in case it generates ideas for enhancing the shape pouring capabilities of Acme::EyeDrops.

Re: Polygon Creation -- Request for Algorithm Suggestions
by Anonymous Monk on Nov 22, 2017 at 20:21 UTC

You say enclosing polygon, by which I'd assume you need a bounding convex polyhedron; the embedded example however shows a non-convex shape. I don't think this makes much of a sense unless the points were ordered (lines) to begin with. In the example, you could reduce the volume by cutting wedges into the shape, thereby making some of the pruned "internal" points appear in the final shape.

I'm not sure what you mean by polyhedron. It's not a 3-dimensional shape, which a polyhedron is by definition.

And no, the points were not ordered to begin with -- they were taken from an image which had no extra information other than (X,Y) pairs of points, and an associated color for each point.

I did look at the module Math::ConvexHull, but determined it didn't do what I needed because if I go with the convex polygon defined for the set of points, it adds more to the shape than necessary, and eats into neighboring shapes to which the algorithm will also eventually be applied.

say  substr+lc crypt(qw \$i3 SI\$),4,5

Aye, a polygon, I stand corrected. It looks to me you have a set of pixels (small squares), or a sprite, and you want vector graphics out of it? The shapes are all solid, with no holes?

If you have pixels, they should fall on a grid. You could just walk the outline on the grid and be done with it.

Re: Polygon Creation -- Request for Algorithm Suggestions
by hdb (Monsignor) on Nov 28, 2017 at 09:59 UTC

I have only scanned the whole thread and I do not want to spoil your programming project but there is a nice list of algorithms on Wikipedia and a Perl implementation on CPAN. (Apologies if this has been mentioned somewhere but I failed to spot it...)

I don't think the OP really wants a hull and if then it wouldn't be convex. (Though stated otherwise)

It seems to be about tracing the - often concave - outline of a compact set of points - the pixel image of a county.

A hull is more general, it doesn't require that the enclosed points are connected.

Cheers Rolf
(addicted to the Perl Programming Language and ☆☆☆☆ :)
Wikisyntax for the Monastery

Thanks for the clarification. I guess at latest while looking at the map of Italy I should have realized that "convex" is not a good description...

Create A New User
Node Status?
node history
Node Type: perlquestion [id://1204060]
Approved by marto
Front-paged by beech
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (5)
As of 2020-11-26 00:42 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?

No recent polls found

Notices?