Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
An update:

roboticus, yours is the method I ultimately went with; thank you again for a great answer.

Your solution seemed both the simplest and quickest to implement.

Another Update:   Going back to my original CGI script, I determined your algorithm wasn't *quite* enough. There are cases when the set of points have not yet been used up, and yet the next point cannot be found, because it's not close enough to the last one. The solution for this seems to be to simply return the closest point not yet used. I've made that change to Shape.pm below.

I abstracted your code into a couple of methods which are now part of my Shape.pm module. The test harness test.pl now simply looks like this:

#!/usr/bin/perl ############### ## Libraries ## ############### use strict; use warnings; use Data::Dumper::Concise; use Function::Parameters; use lib "."; use Shape; ################## ## Main Program ## ################## my $pts = assign_points(); my $sh = Shape->new($pts, 1); my $outline = $sh->outline; printf "[Resulting Outline]\n"; foreach my $a_point (@$outline) { printf "[%s],", join(',', @$a_point); } print "\n"; ################# ## Subroutines ## ################# fun assign_points() { return [ [527,83],[527,84],[526,84],[525,84],[524,84],[523,84],[522,84] +, # ... Many more points -- see the original code ... ]; }

Here is my resulting 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 = [ ], $b_debug = 0) { my $self = { points => $a_points, debug => $b_debug, }; bless $self, $proto; $self->_find_extrema(); $self->{image} = $self->_construct_image(); return $self; } #==================# ## Public methods ## #==================# #=============# ## Accessors ## #=============# method debug() { return $self->{debug} } method points() { return $self->{points} } method image() { return $self->{image} } method extrema() { return @{$self->{extrema}} } # # outline() # # Returns the outline of the shape, constructing it first if necessar +y. # method outline() { if (!$self->{outline}) { $self->remove_interior; my ($x, $y) = $self->find_horizontal_edge(); $self->_find_outline($x, $y); } return $self->{outline}; } # # 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->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; } } method clone_image($a_image = $self->image) { my $a_clone = [ ]; for (my $i = 0; $i < @$a_image; $i++) { my $a_row = $a_image->[$i]; push @$a_clone, [ @$a_row ]; } return $a_clone; } method remove_interior() { my $a_image = $self->image; my $a_new = $self->clone_image($a_image); my $height = @$a_image; my $width = @{$a_image->[0]}; # Temporarily mark interior points for (my $y = 1; $y < $height; $y++) { for (my $x = 1; $x < $width; $x++) { if ($self->_is_interior_point($x, $y, $a_image)) { $a_new->[$y][$x] = 'o'; } } } $self->debug and $self->_print_image($a_new); $self->{image} = $a_new; } method find_horizontal_edge($a_image = $self->image) { my $height = @$a_image; my $width = @{$a_image->[0]}; for (my $y = 0; $y < $height - 1; $y++) { for (my $x = 0; $x < $width - 1; $x++) { my $pt0 = $a_image->[$y][$x] || ' '; my $pt1 = $a_image->[$y][$x+1] || ' '; my $pt2 = $a_image->[$y+1][$x] || ' '; if ($pt0 eq '#' and $pt1 eq '#' and $pt2 eq 'o') { return ( $x, $y ); } } } $self->_fatal("Unable to find a horizontal outer edge"); } #===================# ## Private methods ## #===================# method _debug($msg) { $self->{debug} or return; say $msg; } 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; } # # _is_interior_point($x, $y, $a_image) # # Given a point ($x, $y) and an image $a_image, returns nonzero iff t +hat # point in the image is surrounded on all 4 sides (excluding diagonal +s) # by other points. # method _is_interior_point($x, $y, $a_image = $self->image) { (($a_image->[$y][$x] || ' ') eq '#') or return 0; (($a_image->[$y-1][$x] || ' ') eq '#') or return 0; (($a_image->[$y+1][$x] || ' ') eq '#') or return 0; (($a_image->[$y][$x-1] || ' ') eq '#') or return 0; (($a_image->[$y][$x+1] || ' ') eq '#') or return 0; return 1; } # # _construct_image() # # Creates the 2-dimensional image defined by the shape's points. # method _construct_image() { my ($minx, $miny, $maxx, $maxy) = $self->extrema(); my $height = $maxy - $miny + 1; my $width = $maxx - $minx + 1; my $a_image = [ ]; for (my $i = 0; $i < $height; $i++) { push @$a_image, [ (' ') x $width ]; } my $a_points = $self->points; for my $a_pt (@$a_points) { my ($x, $y) = @$a_pt; $a_image->[$y - $miny][$x - $minx] = '#'; } $self->debug and $self->_print_image($a_image); return $a_image; } method _print_image($a_image = $self->image) { print "\n"; my $a_line0 = $a_image->[0]; my $width = @$a_line0; print " "; for (my $i = 0; $i < $width; $i++) { printf "%d", $i % 10; } print "\n"; for (my $i = 0; $i < @$a_image; $i++) { my $a_line = $a_image->[$i] || 0; $a_line or $self->fatal("Image[$i] is NOT an array"); printf ": %s : % 3u\n", join("", @$a_line), $i; } print "Type [CR]"; <STDIN>; return; } # # _find_extrema # # Finds 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; } my $a_extrema = $self->{extrema} = [ $minx, $miny, $maxx, $maxy ]; return @$a_extrema; } # # _find_outline($x, $y, $a_image) # # Given a horizontal edge point ($x, $y) and an optional image $a_imag +e, # constructs the outline of the shape by walking around it, choosing t +he # best direction each time. # # Thanks to roboticus from perlmonks for the original algorithm. # Ref: http://perlmonks.com/?node_id=1204093 # # Roboticus writes: # We've found a bit of horizontal edge, and we're proceeding in the ++X # direction, and we know the interior of the polygon is on the right + hand # side. # # So we'll build a simple state machine that walks the edge. # # $x, $y - current point on the edge # $in_dir - the direction we came from ## method _find_outline($x, $y, $a_image = $self->image) { # Get the extrema of the shape my ($minx, $miny, $maxx, $maxy) = $self->_find_extrema; # Follow the border my $a_outline = [[ $x + $minx, $y + $miny ]]; my $in_dir = '8'; my $cnt = 0; my $npts = 0; # Total points in image # Discard interior points, which are no longer needed for (my $y = 0; $y < @$a_image; $y++) { my $a_row = $a_image->[$y]; for (my $x = 0; $x < @$a_row; $x++) { ($a_row->[$x] =~ /[ox]/) and $a_row->[$x] = ' '; ($a_row->[$x] eq '#') and ++$npts; } } while (1) { my $sym = chr(65 + $cnt++ % 26); $in_dir = $self->_new_dir($a_image, $npts, \$x, \$y, $in_dir, +$sym); if (!$in_dir) { $npts or last; $self->debug and $self->_print_image($a_image); $self->_fatal("There were $npts unused points"); } push @$a_outline, [ $x + $minx, $y + $miny ]; --$npts; } $self->debug and $self->_print_image($a_image); $self->{outline} = $a_outline; } # # This method is also based on the algorithm by roboticus from perlmon +ks # # The direction code maps to the following directions: # # 6 # 5 ^ 7 # \ | / # \ | / # 4 <--- o ---> 8 # / | \ # / | \ # 3 v 1 # 2 # ## method _new_dir($a_image, $npts, $s_x, $s_y, $in_dir, $sym) { my $height = @$a_image; my $width = @{$a_image->[0]}; # Input dirction mapped to preferred output direction my $h_dirs = { '1' => [qw( 3 4 5 6 7 8 2 )], '2' => [qw( 3 4 5 6 7 8 1 )], '3' => [qw( 4 5 6 7 8 1 2 )], '4' => [qw( 5 6 7 8 1 2 3 )], '5' => [qw( 6 7 8 1 2 3 4 )], '6' => [qw( 7 8 1 2 3 4 5 )], '7' => [qw( 1 2 3 4 5 6 )], '8' => [qw( 3 4 5 6 7 )], }; # Delta X, Y and new input direction IN [ dx, dy, newdir ] my $h_deltas = { '1' => [ -1, -1, '5' ], '2' => [ 0, -1, '6' ], '3' => [ 1, -1, '7' ], '4' => [ 1, 0, '8' ], '5' => [ 1, 1, '1' ], '6' => [ 0, 1, '2' ], '7' => [ -1, 1, '3' ], '8' => [ -1, 0, '4' ], }; my $a_dirs = $h_dirs->{$in_dir}; for my $dir (@$a_dirs) { my ($dx, $dy, $newdir) = @{$h_deltas->{$dir}}; my ($x1, $y1) = ($$s_x + $dx, $$s_y + $dy); if ($x1 >= 0 and $y1 >= 0 and $x1 < $width and $y1 < $height) +{ my $pixel = $a_image->[$y1][$x1] || ' '; if ($pixel eq '#') { $$s_x += $dx; $$s_y += $dy; $a_image->[$$s_y][$$s_x] = $sym; return $newdir; } } } # If there are still unused points in the image, just pick # the closest point and use that. ## ($npts > 0) and return $self->_closest_point($a_image, $s_x, $s_y, + $sym); return 0; } method _distance($x0, $y0, $x1, $y1) { return sqrt(($y1 - $y0) ** 2 + ($x1 - $x0) ** 2); } method _closest_point($a_image, $s_x, $s_y, $sym) { my $mindist = 9999; my ($x1, $y1); for (my $y = 0; $y < @$a_image; $y++) { my $a_row = $a_image->[$y]; for (my $x = 0; $x < @$a_row; $x++) { ($x == $$s_x and $y == $$s_y) and next; my $pixel = $a_image->[$y][$x] || ' '; if ($pixel eq '#') { my $newdist = $self->_distance($x, $y, $$s_x, $$s_y); if ($newdist < $mindist) { ($mindist, $x1, $y1) = ($newdist, $x, $y); } } } } my $dx = $x1 - $$s_x; my $dy = $y1 - $$s_y; $$s_x = $x1; $$s_y = $y1; $a_image->[$$s_y][$$s_x] = '*'; (0 == $dx) and return ($dy < 0)? 6: 2; # North or South (0 == $dy) and return ($dx < 0)? 4: 8; # West or East ($dx < 0) and return ($dy < 0)? 5: 3; # Northwest or Southwest ($dx > 0) and return ($dy < 0)? 7: 1; # Northeast or Southeast return 0; } 1;
say  substr+lc crypt(qw $i3 SI$),4,5

In reply to Re^7: Polygon Creation -- Request for Algorithm Suggestions by golux
in thread Polygon Creation -- Request for Algorithm Suggestions by golux

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others admiring the Monastery: (4)
As of 2024-03-29 00:31 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found