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.

In reply to Re^10: Polygon Creation -- Request for Algorithm Suggestions by roboticus
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":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.