Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

Polygon Creation -- Request for Algorithm Suggestions

by golux (Chaplain)
on Nov 22, 2017 at 19:13 UTC ( #1204060=perlquestion: print w/replies, xml ) 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} } # # add_point($a_point) # # Adds a point to the shape, in the format [ $x, $y ]. # # method add_point($a_point) { 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 @answerpoints; 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 #use Data::Dump 'pp'; pp \@answerpoints; # the real answer :) 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

        Found this http://stackoverflow.com/questions/7408470/given-a-vector-of-points-possibly-out-of-order-find-polygon-not-convex-hull

        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

        added clarification

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; for (@answerpoints) # add letters for display if wanted { my ($x, $y) = @$_; pos($grid) = $x - $minx + 1 + ($y - $miny + 1) * $gw; $grid =~ s/\G#/$letters[$i++ % @letters]/; # label point if not } print $grid; #use Data::Dump 'pp'; pp \@answerpoints; # the real answer :) 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 ); #use Data::Dump 'pp'; pp \@answerpoints; # the real answer :) my $i = 0; for (@answerpoints) # add letters for display if wanted { my ($x, $y) = @$_; pos($grid) = $x - $minx + 1 + ($y - $miny + 1) * $gw; $grid =~ s/\G#/$letters[$i++ % @letters]/; # label point if not } print $grid; draw(@answerpoints); # for Tk } 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], }

      tybalt89:

      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).

    2. Apply your algorithm.

    Original fragment:

    # # # # .
    # # # . .
    # # . . .
    # # # # .
    # # . . .
    

    After your algorithm:

    # # # # .
    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...

Log In?
Username:
Password:

What's my password?
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?