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'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".
say
substr+lc crypt(qw $i3 SI$),4,5
I've abstracted what I have so far into a short test program "test.pl":
and a corresponding module "Shape.pm":#!/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], ]; }
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 ); }
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.
|
---|
Back to
Seekers of Perl Wisdom