Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

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

by roboticus (Chancellor)
on Nov 26, 2017 at 19:22 UTC ( [id://1204293]=note: print w/replies, xml ) Need Help??


in reply to Re^9: Polygon Creation -- Request for Algorithm Suggestions
in thread Polygon Creation -- Request for Algorithm Suggestions

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# # # # # # # # #

...roboticus

When your only tool is a hammer, all problems look like your thumb.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://1204293]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others avoiding work at the Monastery: (7)
As of 2024-03-28 08:28 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found