Re^7: Polygon Creation -- Request for Algorithm Suggestions

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 ...
  ];
}
[download]

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;
[download]

say substr+lc crypt(qw $i3 SI$),4,5

Comment on Re^7: Polygon Creation -- Request for Algorithm Suggestions Select or Download Code

Replies are listed 'Best First'.
Re^8: Polygon Creation -- Request for Algorithm Suggestions by huck (Prior) on Nov 24, 2017 at 20:22 UTC
I too was interested in that method, but the numbers kept "throwing" me, so i changed it to my %dirs = ( # IN [ preferred output directions ] # '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 )], 'nw' => [qw( ne e se s sw w n )], 'n' => [qw( ne e se s sw w nw )], 'ne' => [qw( e se s sw w nw n )], 'e' => [qw( se s sw w nw n ne )], 'se' => [qw( s sw w nw n ne e )], 's' => [qw( sw w nw n ne e se )], 'sw' => [qw( nw n ne e se s )], 'w' => [qw( ne e se s sw )], ); my %dels = ( # IN [ dx, dy, new_in_dir ] #nw '1' => [ -1, -1, '5' ], #n '2' => [ 0, -1, '6' ], #ne '3' => [ 1, -1, '7' ], #e '4' => [ 1, 0, '8' ], #se '5' => [ 1, 1, '1' ], #s '6' => [ 0, 1, '2' ], #sw '7' => [ -1, 1, '3' ], #w '8' => [ -1, 0, '4' ], 'nw' => [ -1, -1, 'se' ], 'n' => [ 0, -1, 's' ], 'ne' => [ 1, -1, 'sw' ], 'e' => [ 1, 0, 'w' ], 'se' => [ 1, 1, 'nw' ], 's' => [ 0, 1, 'n' ], 'sw' => [ -1, 1, 'ne' ], 'w' => [ -1, 0, 'e' ], ); [download] With a `my $in_dir = 'w';` to start it off. in_dir is the direction you came from, while the states are named in the direction they "look" To watch it work i changed the outer2 loop to OUTER2: while (1) { my @dirs = @{$dirs{$in_dir}}; my $orig_dir=$in_dir; my $tests=''; for my $d (@dirs) { my ($dx, $dy, $new_in_dir) = @{$dels{$d}}; $tests.= sprintf(" %2s",$d); if (($img[$y+$dy][$x+$dx]//' ') eq '#') { ++$cnt; $in_dir = $new_in_dir; $y += $dy; $x += $dx; $img[$y][$x] = chr(65 + $cnt%26); print '' .' indir '.sprintf("%2s",$orig_dir) .' to ' .sprintf("%2s",$in_dir) .' code ' .$img[$y][$x] .' path ' .sprintf('%24s',$tests) ." ($x,$y)\n"; push @points_in_order, [ $x, $y ]; next OUTER2; } } print "Can't find anywhere to go! ('$in_dir': $x, $y)\n"; last OUTER2; } [download] which gives me output like Found a bit of horizontal top edge at 22, 1 indir w to w code B path ne e (23,1) indir w to w code C path ne e (24,1) indir w to w code D path ne e (25,1) indir w to w code E path ne e (26,1) indir w to w code F path ne e (27,1) indir w to w code G path ne e (28,1) indir w to sw code H path ne (29,0) indir sw to n code I path nw n ne e se s (29,1) indir n to n code J path ne e se s (29,2) indir n to n code K path ne e se s (29,3) indir n to n code L path ne e se s (29,4) indir n to nw code M path ne e se (30,5) indir nw to w code N path ne e (31,5) indir w to nw code O path ne e se (32,6) indir nw to w code P path ne e (33,6) indir w to w code Q path ne e (34,6) indir w to w code R path ne e (35,6) indir w to w code S path ne e (36,6) indir w to w code T path ne e (37,6) indir w to w code U path ne e (38,6) indir w to sw code V path ne (39,5) indir sw to n code W path nw n ne e se s (39,6) indir n to n code X path ne e se s (39,7) indir n to n code Y path ne e se s (39,8) indir n to n code Z path ne e se s (39,9) indir n to n code A path ne e se s (39,10) indir n to n code B path ne e se s (39,11) indir n to n code C path ne e se s (39,12) indir n to n code D path ne e se s (39,13) indir n to n code E path ne e se s (39,14) indir n to n code F path ne e se s (39,15) indir n to n code G path ne e se s (39,16) indir n to n code H path ne e se s (39,17) indir n to n code I path ne e se s (39,18) indir n to n code J path ne e se s (39,19) indir n to n code K path ne e se s (39,20) indir n to n code L path ne e se s (39,21) indir n to n code M path ne e se s (39,22) indir n to n code N path ne e se s (39,23) indir n to ne code O path ne e se s sw (38,24) indir ne to n code P path e se s (38,25) indir n to n code Q path ne e se s (38,26) indir n to n code R path ne e se s (38,27) indir n to n code S path ne e se s (38,28) indir n to ne code T path ne e se s sw (37,29) indir ne to ne code U path e se s sw (36,30) indir ne to e code V path e se s sw w (35,30) indir e to e code W path se s sw w (34,30) indir e to e code X path se s sw w (33,30) indir e to e code Y path se s sw w (32,30) indir e to s code Z path se s sw w nw n (32,29) indir s to se code A path sw w nw (31,28) indir se to e code B path s sw w (30,28) indir e to e code C path se s sw w (29,28) indir e to e code D path se s sw w (28,28) indir e to e code E path se s sw w (27,28) indir e to e code F path se s sw w (26,28) indir e to se code G path se s sw w nw (25,27) indir se to e code H path s sw w (24,27) indir e to e code I path se s sw w (23,27) indir e to e code J path se s sw w (22,27) indir e to se code K path se s sw w nw (21,26) indir se to e code L path s sw w (20,26) indir e to e code M path se s sw w (19,26) indir e to e code N path se s sw w (18,26) indir e to e code O path se s sw w (17,26) indir e to e code P path se s sw w (16,26) indir e to e code Q path se s sw w (15,26) indir e to se code R path se s sw w nw (14,25) indir se to e code S path s sw w (13,25) indir e to e code T path se s sw w (12,25) indir e to e code U path se s sw w (11,25) indir e to e code V path se s sw w (10,25) indir e to se code W path se s sw w nw (9,24) indir se to se code X path s sw w nw (8,23) indir se to s code Y path s sw w nw n (8,22) indir s to s code Z path sw w nw n (8,21) indir s to se code A path sw w nw (7,20) indir se to s code B path s sw w nw n (7,19) indir s to s code C path sw w nw n (7,18) indir s to se code D path sw w nw (6,17) indir se to s code E path s sw w nw n (6,16) indir s to s code F path sw w nw n (6,15) indir s to se code G path sw w nw (5,14) indir se to e code H path s sw w (4,14) indir e to e code I path se s sw w (3,14) indir e to s code J path se s sw w nw n (3,13) indir s to s code K path sw w nw n (3,12) indir s to s code L path sw w nw n (3,11) indir s to s code M path sw w nw n (3,10) indir s to se code N path sw w nw (2,9) indir se to se code O path s sw w nw (1,8) indir se to se code P path s sw w nw (0,7) indir se to s code Q path s sw w nw n (0,6) indir s to sw code R path sw w nw n ne (1,5) indir sw to nw code S path nw n ne e se (2,6) indir nw to n code T path ne e se s (2,7) indir n to nw code U path ne e se (3,8) indir nw to w code V path ne e (4,8) indir w to nw code W path ne e se (5,9) indir nw to w code X path ne e (6,9) indir w to nw code Y path ne e se (7,10) indir nw to w code Z path ne e (8,10) indir w to nw code A path ne e se (9,11) indir nw to w code B path ne e (10,11) indir w to w code C path ne e (11,11) indir w to w code D path ne e (12,11) indir w to nw code E path ne e se (13,12) indir nw to w code F path ne e (14,12) indir w to w code G path ne e (15,12) indir w to w code H path ne e (16,12) indir w to sw code I path ne (17,11) indir sw to s code J path nw n (17,10) indir s to s code K path sw w nw n (17,9) indir s to s code L path sw w nw n (17,8) indir s to s code M path sw w nw n (17,7) indir s to sw code N path sw w nw n ne (18,6) indir sw to sw code O path nw n ne (19,5) indir sw to sw code P path nw n ne (20,4) indir sw to s code Q path nw n (20,3) indir s to s code R path sw w nw n (20,2) indir s to w code S path sw w nw n ne e (21,2) indir w to sw code T path ne (22,1) Can't find anywhere to go! ('sw': 22, 1) [download] I found this much easier to follow.	[reply] [d/l] [select]
Re^9: Polygon Creation -- Request for Algorithm Suggestions by roboticus (Chancellor) on Nov 25, 2017 at 00:05 UTC
huck: I'm sorry I didn't describe my algorithm better the first time. Had I done so, you probably wouldn't have had to wrestle with it. I meant to describe it better, but lost track of some of the things I said vs. some of the things I meant to say. I'm sure it would've also been clearer had I not left some entries out of the %dirs hash, and had I mentioned that it's simply doing a clockwise sweep looking for the next border point. I was also troubled by my numbering scheme, but wasn't able to come up with something cleaner. I'm certain that a bit of thinking might give a much better solution that what I currently have. But what I have is good enough for me, for now. 8^) ...roboticus When your only tool is a hammer, all problems look like your thumb.	[reply]
Re^8: Polygon Creation -- Request for Algorithm Suggestions by roboticus (Chancellor) on Nov 24, 2017 at 23:59 UTC
golux: I'm glad it was useful to you. While perusing your implementation, I noticed that I didn't fully fill out the `%dirs` map. I don't think I bothered to mention it, but the way it works is that from each step, it sweeps an arc clockwise based on the current point and the location it arrived from. That's the reason that it wants the bulk of the polygon on the right-hand side. If you wanted to put the bulk of the polygon on the left hand side, you'd simply reverse the arc direction on the lists. Since you indicated that it was interesting, I implemented some of the bits I thought up while enjoying Thanksgiving, and spent a little time cleaning up some of the ugly parts and removed some of the hacky bits: The hack I most wanted to remove was the part where I edited the polygon while building the points-in-order list. That prevens the algorithm from working on sections a single pixel thick, since it couldn't traverse both directions in that case. Next, I removed the part where I removed the interior, as I no longer needed it. If you want to remove the interior, you can do as the current version does, and simply render the in-order list on a blank canvas. Finally, I removed the ugly %dirs thing. Since we're just tracing an arc based on the incoming direction, I built a list that wrapped around nearly twice, and used the incoming direction to select the starting point of the list. I hope you also find this one amusing and/or useful. Read more... (7 kB) The output of the current version shows an example of a thin section, and shows also that it will only look at a single connected polygon. If you want to handle disjoint point sets, you should be able to do so simply by finding a starting point on each chunk, and looping over them. $ perl ~/pm_1204060_b.pl Bounds X:1..40, Y:1..31 Original image (relocated, pixels set to '#'): : # : 0 : ######## : 1 : ####### ########## : 2 : ######################## : 3 : ####### ########## : 4 : # ############# # : 5 : ### ###################### : 6 : ### ####################### : 7 : #### ####################### : 8 : ##### ####################### : 9 : ###### ####################### : 10 : ########## ####################### : 11 : ##################################### : 12 : ##################################### : 13 : ##################################### : 14 : ################################## : 15 : ################################## : 16 : ################################## : 17 : ################################# : 18 : ################################# : 19 : ################################# : 20 : ################################ : 21 : ################################ : 22 : ################################ : 23 : ############################## : 24 : ############################# : 25 : ######################## : 26 : ######## ################# : 27 : ######## ############# : 28 : ######## ###### : 29 : ##### : 30 : : 31 1234567890123456789012345678901234567890 Found a bit of horizontal top edge at 22, 1 Points rendered on blank canvas: : H : 0 : tBCDEFGI : 1 : efghijk rs J : 2 : d lmnopq K : 3 : cbaZYXW P L : 4 : r O MN V : 5 : q s N OPQRSTUW : 6 : p t M X : 7 : o uv L Y : 8 : n wx K Z : 9 : m yz J a : 10 : l ABCD I b : 11 : k EFGH c : 12 : j d : 13 : ihg e : 14 : f f : 15 : e g : 16 : d h : 17 : c i : 18 : b j : 19 : a k : 20 : Z l : 21 : Y m : 22 : X n : 23 : W o : 24 : VUTSR p : 25 : QPONMLK q : 26 : JIHG r : 27 : FEDCBA s : 28 : z t : 29 : yxwvu : 30 : : 31 1234567890123456789012345678901234567890 Border points rendered on original polygon: : H : 0 : tBCDEFGI : 1 : efghijk rs#######J : 2 : d#######lmnopq#########K : 3 : cbaZYXW P########L : 4 : r O##########MN V : 5 : q#s N#############OPQRSTUW : 6 : p#t M#####################X : 7 : o#uv L#####################Y : 8 : n##wx K#####################Z : 9 : m###yz J#####################a : 10 : l#####ABCD I#####################b : 11 : k#########EFGH######################c : 12 : j###################################d : 13 : ihg#################################e : 14 : f################################f : 15 : e################################g : 16 : d################################h : 17 : c###############################i : 18 : b###############################j : 19 : a###############################k : 20 : Z##############################l : 21 : Y##############################m : 22 : X##############################n : 23 : W############################o : 24 : VUTSR#######################p : 25 : QPONMLK################q : 26 : ######## JIHG############r : 27 : ######## FEDCBA######s : 28 : ######## z####t : 29 : yxwvu : 30 : : 31 1234567890123456789012345678901234567890 [download] I hope you also find this one interesting. Update: Now that I look at it, I could remove the new_in_dir entry from the %dirs hash, and just look it up from @dirlist, like `$new_in_dir = @dirlist[4+$in_dir];`. ...roboticus When your only tool is a hammer, all problems look like your thumb.	[reply] [d/l] [select]
Re^8: Polygon Creation -- Request for Algorithm Suggestions by vr (Curate) on Nov 24, 2017 at 23:54 UTC
Hi, just a note: looks like algorithm fails with "spikes" or "whiskers" i.e. single pixel protrusions, kind of: `fun assign_points() { # ....... # .#...... # .#...... # .####... # .####... # .####... # .######. # .#...... # .#...... # ........ return [ [1,1], [1,2], [1,3],[2,3],[3,3],[4,3], [1,4],[2,4],[3,4],[4,4], [1,5],[2,5],[3,5],[4,5], [1,6],[2,6],[3,6],[4,6],[5,6],[6,6], [1,7], [1,8], ]; }` [download] And: `012345 : # : 0 : # : 1 : #### : 2 : #### : 3 : #### : 4 : ###### : 5 : # : 6 : # : 7 Type [CR] 012345 : # : 0 : # : 1 : #### : 2 : #oo# : 3 : #oo# : 4 : ###### : 5 : # : 6 : # : 7 Type [CR] 012345 : # : 0 : # : 1 : ##AB : 2 : # C : 3 : # D : 4 : ####EF : 5 : # : 6 : # : 7 Type [CR] [Resulting Outline] [1,2],[2,2],[3,2],[3,3],[3,4],[4,5],[5,5],` [download] I thought polyline must retreat its steps along such protrusions, cf. output from my program: `........ .0...... .1...... .2765... .3..4... .4..3... .589012. .6...... .7...... ........` [download] Plus, not sure if it's safe to always hope for horizontal AND "interior on the right if moving CW" edge present -- circles, ~~upside-down~~ triangles, etc. -- but, it's your application and you know what input to expect. Edit:About triangles. + Not sure about the rule. But simple 3x3 triangle fails.	[reply] [d/l] [select]
Re^9: Polygon Creation -- Request for Algorithm Suggestions by roboticus (Chancellor) on Nov 25, 2017 at 01:06 UTC
vr: My starting point finder (first horizontal bit on highest line) is definitely not a safe way to find a starting point. I knew that, but didn't really think of mentioning it. Even worse: I was hoping the faults you found with the code was due to the missing entries in the %dirs hash, but some caused a bit of grief. I've got it going a little better, but I'm still testing it now. I'll post (yet another) version when I get the current kinks out. One of the test cases with spindles in various directions: $ perl ~/pm_1204060_b.pl ugly.2 Bounds X:0..13, Y:2..12 Original image (relocated, pixels set to '#'): : ############## : 0 : # : 1 : # : 2 : ####### : 3 : #### : 4 : #### : 5 : ####### : 6 : ### : 7 : # : 8 : # : 9 : # : 10 : : 11 12345678901234 Found a bit of horizontal top edge at 3, 0 Start point: : ###+########## : 0 : # : 1 : # : 2 : ####### : 3 : #### : 4 : #### : 5 : ####### : 6 : ### : 7 : # : 8 : # : 9 : # : 10 : : 11 12345678901234 Points rendered on blank canvas: : yzABPONMLKJI : 0 : v : 1 : u : 2 : tSTUZYX : 3 : s a : 4 : r b : 5 : opql c : 6 : kjd : 7 : i : 8 : h : 9 : g : 10 : : 11 12345678901234 Border points rendered on original polygon: : yzABPONMLKJI## : 0 : v : 1 : u : 2 : tSTUZYX : 3 : s##a : 4 : r##b : 5 : opql##c : 6 : kjd : 7 : i : 8 : h : 9 : g : 10 : : 11 12345678901234 [download] ...roboticus When your only tool is a hammer, all problems look like your thumb.	[reply] [d/l]
Re^10: Polygon Creation -- Request for Algorithm Suggestions by roboticus (Chancellor) on Nov 26, 2017 at 19:22 UTC
OK, this is as good as it's gonna get. Rather, it's as good as I plan on making it. ;^) Via (not exhaustive) testing, it seems that the best compromise for choosing the starting point is finding the upperleftmost point and pretending I came in from up and left. I've not caused that approach to fail. Current weaknesses: If you select a different starting point that happens to be on a 'spindle', then it'll terminate early, as it currently stops when it hits it's starting point again. (You can see this by running it without an input file: the rightmost figure will be incomplete.) It could be fixed by going back and finding the set of boundary points, and then stopping instead when the length of the output points matches, but I don't really want to go back and find the boundary points again. Anyway, I'm done with this pastime, and am moving on to another. I hope it's useful... use strict; use warnings; use Data::Dump 'pp'; my @dirlist = (qw(1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8)); my %dels = ( # IN [ dx, dy, new_in_dir ] '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' ], ); ### # Read the image, converting non-space characters into '#' ### my $FName = shift; my $FH; if (defined $FName) { open $FH, '<', $FName or die "$FName: $!"; } else { $FH = \DATA; } my ($rPoints, $rStarts) = read_image($FH); my @pts = @$rPoints; my @starts; @starts = @$rStarts unless exists $ENV{ROBO_HIDE_STARTS}; print pp(\@starts), "\n"; #my @pts = read_image($FH); ### # Find bounds of figure ### my ($minX, $minY) = (0,0); #999999999,999999999); my ($maxX, $maxY) = (-$minX, -$minY); for my $ar (@pts) { my ($x,$y) = @$ar; $minX = $x if $x < $minX; $maxX = $x if $x > $maxX; $minY = $y if $y < $minY; $maxY = $y if $y > $maxY; } print "Bounds X:$minX..$maxX, Y:$minY..$maxY\n"; ### # Build a blank canvas and the original output image ### my @canvas; push @canvas, [ (' ') x ($maxX - $minX + 1) ] for 0 .. $maxY-$minY+1; my @original = copy_array(@canvas); for my $ar (@pts) { my ($x, $y) = @$ar; $x -= $minX; $y -= $minY; $original[$y][$x] = '#'; } print "Original image (relocated, pixels set to '#'):\n"; print_array(@original); ### # Find a horizonal bit of edge from the top of the picture # NOTE: NOT ROBUST (it can be fooled). ### my ($in_dir, $start_x, $start_y); my @ximg = copy_array(@original); my @img = copy_array(@original); my @points_in_order; if (@starts) { for my $ar (@starts) { ($in_dir, $start_x, $start_y) = @$ar; print "Start ($start_x,$start_y) from dir $in_dir\n"; $ximg[$start_y][$start_x] = '+'; trace_border(); } } else { ($in_dir, $start_x, $start_y) = find_start_point(@original); $ximg[$start_y][$start_x] = '+'; trace_border(); } print "Start point(s):\n"; print_array(@ximg); ### # Build our list or border points by walking clockwise around the # border of the polygon. # # NOTE: find_start_point needs to choose a point and incoming # direction to let us walk the polygon edge clockwise. # # $x, $y - current point on the edge # $in_dir - the direction we came from # # TODO: Turn into a proper function ### sub trace_border { print "\n***************** ($start_x, $start_y) <$in_dir>\n"; push @points_in_order, [ $start_x, $start_y ]; my ($x, $y) = ($start_x, $start_y); my $cnt=0; do { ++$cnt; last if $cnt>100; # Check clockwise arc for next colored pixel my @dirs = @dirlist[0+$in_dir .. 7+$in_dir]; print "($x,$y) <$in_dir> ", join(", ", @dirs), "\n"; for my $d (@dirs) { #my ($dx, $dy, $new_in_dir) = @{$dels{$d}}; my ($dx, $dy) = @{$dels{$d}}; my $new_in_dir = $dirlist[4+$d]; my ($tx, $ty) = ($x+$dx, $y+$dy); next if $tx<0 or $tx>$#{$img[$ty]}; next if $ty<0 or $ty>$#img; print "\t($dx,$dy) <$new_in_dir> '$img[$ty][$tx]'\n"; #next if $tx < 0 or $ty < 0; #next if $tx > $maxX-2 or $ty > $maxY-2; if ($img[$ty][$tx] eq '#') { ($in_dir, $x, $y) = ($new_in_dir, $tx, $ty); push @points_in_order, [ $x, $y ]; last; } } } until ($x == $start_x and $y == $start_y); } ### # Render the points on a blank canvas ### my $fn_next_border_char; if (! exists $ENV{ROBOT_HIDE_ON_BLANK}) { $fn_next_border_char = border_char_iterator(); my @img = copy_array(@canvas); for my $i (0 .. $#points_in_order) { my ($x,$y) = @{$points_in_order[$i]}; $img[$y][$x] = $fn_next_border_char->(); } print "\nPoints rendered on blank canvas:\n"; print_array(@img); } ### # Draw 'em on the solid shape, to verify that border is correct ### if (!exists $ENV{ROBO_HIDE_ON_ORIG}) { @img = copy_array(@original); $fn_next_border_char = border_char_iterator(); for my $i (0 .. $#points_in_order) { my ($x,$y) = @{$points_in_order[$i]}; $img[$y][$x] = $fn_next_border_char->(); } print "\nBorder points rendered on original polygon:\n"; print_array(@img); } sub border_char_iterator { my $cnt = 0; my $border_chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrst +uvwxyz"; return sub { return substr($border_chars, $cnt++%length($border_chars), 1); } } sub print_array { print "\n"; my @array = @_; for my $i (0 .. $#array) { print ": ", join("", @{$array[$i]}), " : ", sprintf("% 3u",$i) +, "\n"; } print " "; print substr("1234567890"x20, 0, scalar(@{$array[0]})), "\n\n"; } sub copy_array { my @array = @_; my @ret; for my $ar (@array) { push @ret, [ @$ar ]; } return @ret; } sub read_image { my $FH = shift; my @points; my @starts; while (my $line = <$FH>) { my @chars = split //, $line; for my $x (0 .. $#chars) { if ($chars[$x] !~ /\s/) { push @points, [ $x, $. ]; } if ($chars[$x] =~ /[1-8]/) { push @starts, [ $chars[$x], $x, $. ]; } } } return [@points], [@starts]; } ### # Seems like using the upperleft most pixel I can find, # coming in from direction 1 seems pretty robust. ### sub find_start_point { my @original = @_; for my $iy (0 .. $#original-1) { for my $ix (0 .. $#{$original[0]}-1) { return '1', $ix, $iy if $original[$iy][$ix] eq '#'; } } } __DATA__ # # # # # # # # #### #### #### #### #### ###2 #### #### 6### #### #### #### ####### ####### ##4#### #####8# # # # # # # # # [download] ...roboticus When your only tool is a hammer, all problems look like your thumb.	[reply] [d/l]


Pathologically Eclectic Rubbish Lister
	PerlMonks