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.
In reply to Polygon Creation -- Request for Algorithm Suggestions by golux
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |