#!/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],[515,100], [516,100],[517,100],[518,100],[519,100],[520,100],[521,100],[522,100], [523,100],[524,100],[525,100],[526,100],[527,100],[528,100],[529,100], [530,100],[531,100],[532,100],[533,100],[534,100],[535,100],[536,100], [537,100],[537,101],[536,101],[535,101],[534,101],[533,101],[532,101], [531,101],[530,101],[529,101],[528,101],[527,101],[526,101],[525,101], [524,101],[523,101],[522,101],[521,101],[520,101],[519,101],[518,101], [517,101],[516,101],[515,101],[514,101],[513,101],[512,101],[511,101], [510,101],[509,101],[508,101],[507,101],[506,101],[505,101],[505,102], [506,102],[507,102],[508,102],[509,102],[510,102],[511,102],[512,102], [513,102],[514,102],[515,102],[516,102],[517,102],[518,102],[519,102], [520,102],[521,102],[522,102],[523,102],[524,102],[525,102],[526,102], [527,102],[528,102],[529,102],[530,102],[531,102],[532,102],[533,102], [534,102],[535,102],[536,102],[537,102],[537,103],[536,103],[535,103], [534,103],[533,103],[532,103],[531,103],[530,103],[529,103],[528,103], [527,103],[526,103],[525,103],[524,103],[523,103],[522,103],[521,103], [520,103],[519,103],[518,103],[517,103],[516,103],[515,103],[514,103], [513,103],[512,103],[511,103],[510,103],[509,103],[508,103],[507,103], [506,103],[505,103],[506,104],[507,104],[508,104],[509,104],[510,104], [511,104],[512,104],[513,104],[514,104],[515,104],[516,104],[517,104], [518,104],[519,104],[520,104],[521,104],[522,104],[523,104],[524,104], [525,104],[526,104],[527,104],[528,104],[529,104],[530,104],[531,104], [532,104],[533,104],[534,104],[535,104],[536,104],[537,104],[537,105], [536,105],[535,105],[534,105],[533,105],[532,105],[531,105],[530,105], [529,105],[528,105],[527,105],[526,105],[525,105],[524,105],[523,105], [522,105],[521,105],[520,105],[519,105],[518,105],[517,105],[516,105], [515,105],[514,105],[513,105],[512,105],[511,105],[510,105],[509,105], [508,105],[507,105],[506,105],[506,106],[507,106],[508,106],[509,106], [510,106],[511,106],[512,106],[513,106],[514,106],[515,106],[516,106], [517,106],[518,106],[519,106],[520,106],[521,106],[522,106],[523,106], [524,106],[525,106],[526,106],[527,106],[528,106],[529,106],[530,106], [531,106],[532,106],[533,106],[534,106],[535,106],[536,106],[537,106], [536,107],[535,107],[534,107],[533,107],[532,107],[531,107],[530,107], [529,107],[528,107],[527,107],[526,107],[525,107],[524,107],[523,107], [522,107],[521,107],[520,107],[519,107],[518,107],[517,107],[516,107], [515,107],[514,107],[513,107],[512,107],[511,107],[510,107],[509,107], [508,107],[507,107],[508,108],[509,108],[510,108],[511,108],[512,108], [513,108],[514,108],[515,108],[516,108],[517,108],[518,108],[519,108], [520,108],[521,108],[522,108],[523,108],[524,108],[525,108],[526,108], [527,108],[528,108],[529,108],[530,108],[531,108],[532,108],[533,108], [534,108],[535,108],[536,108],[536,109],[535,109],[534,109],[533,109], [532,109],[531,109],[530,109],[529,109],[528,109],[527,109],[526,109], [525,109],[524,109],[523,109],[522,109],[521,109],[520,109],[519,109], [518,109],[517,109],[516,109],[515,109],[514,109],[513,109],[520,110], [521,110],[522,110],[523,110],[524,110],[525,110],[526,110],[527,110], [528,110],[529,110],[530,110],[531,110],[532,110],[533,110],[534,110], [535,110],[536,110],[536,111],[535,111],[534,111],[533,111],[532,111], [531,111],[530,111],[529,111],[528,111],[527,111],[526,111],[525,111], [524,111],[530,112],[531,112],[532,112],[533,112],[534,112],[535,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 ); }