Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

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

by golux (Chaplain)
on Nov 22, 2017 at 21:41 UTC ( #1204081=note: print w/replies, xml ) Need Help??


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

Yes you're correct, it's a set of pixels originally. The shapes are all solid (no holes) and as I mentioned, my pruning algorithm seems to be a plausible first step to narrowing it down to the outline.

But the "walk the outline" step, as you say, is exactly where I'm stuck. I'm searching for an algorithm that will give me the correct order of points that define that outline/perimeter. If there are any points out of order, they will either cut lines across the shape, or (worse) create regions which are outside of the shape.

say  substr+lc crypt(qw $i3 SI$),4,5
  • Comment on Re^4: Polygon Creation -- Request for Algorithm Suggestions

Replies are listed 'Best First'.
Re^5: Polygon Creation -- Request for Algorithm Suggestions
by roboticus (Chancellor) on Nov 23, 2017 at 00:24 UTC

    golux:

    Here's a "walk the outline" thing. The gist of it is that we have a little state machine that will walk the border for us. The machine wants to follow the border such that it keeps the interior of the polygon on the right hand side. It tracks $x and $y as the current border point, and $in_dir is the direction it came from. Then it looks up the preferred directions to look for the next point.

    Other than your starting point list, I ignored your code. (Not that there's anything wrong with your code, but I just wanted to start from scratch.) As such, you'll probably want to rework it a good bit.

    Frequently when I get some code together, I'll clean it up before posting, but I'll leave it in it's current form for you, ugly debugging traces and all! (Though I left out your original point data to save 100+ lines.) There are a few things I'd clean up if I felt like looking at it any further, but I'll leave it as an exercise for the reader. Ping me if there are any details you'd like clarified.

    $ cat pm_1204060.pl use strict; use warnings; use Data::Dump 'pp'; my @pts = ( . . . your original point list elided for brevity . . . ); # Find bounds of figure my ($minX, $minY) = (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 image my @img; push @img, [ (' ') x ($maxX - $minX + 1) ] for 0 .. $maxY-$minY+1; for my $ar (@pts) { my ($x, $y) = @$ar; $x -= $minX; $y -= $minY; $img[$y][$x] = '#'; } print_array(@img); my @img2 = copy_array(@img); # Annihilate the interior for my $y (1 .. $#img-1) { for my $x (1 .. $#{$img[$y]}-1) { next unless $img[$y][$x] eq '#'; next if $img[$y-1][$x] ne '#'; next if $img[$y+1][$x] ne '#'; next if $img[$y][$x-1] ne '#'; next if $img[$y][$x+1] ne '#'; $img2[$y][$x] = '.'; } } print_array(@img2); # Find a horizonal bit of edge from the top of the picture # (so we can ensure that the interior of the image is on the right) my ($x, $y); OUTER: for my $iy (0 .. $#img2) { for my $ix (0 .. $#{$img2[0]}) { if ($img2[$iy][$ix] eq '#' and $img2[$iy][$ix+1] eq '#' and $img2[$iy+1][$ix] eq '.') { $x = $ix; $y = $iy; last OUTER; } } } print "Found a bit of horizontal top edge at $x, $y\n"; # 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 # # For each incoming direction, build a list of possible 'next points' # in the preferred order (assuming that interior of polygon is on # the right-hand side): 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 )], ); 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' ], ); # Follow the border my @points_in_order; my $in_dir = '8'; $img[$y][$x] = '*'; push @points_in_order, [$x, $y]; my $cnt = 0; @img = copy_array(@img2); OUTER2: while (1) { my @dirs = @{$dirs{$in_dir}}; for my $d (@dirs) { my ($dx, $dy, $new_in_dir) = @{$dels{$d}}; print "indir $in_dir ($new_in_dir: $dx, $dy)\n"; 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 " ($x,$y) $img[$y][$x] $in_dir\n"; push @points_in_order, [ $x, $y ]; next OUTER2; } } print "Can't find anywhere to go! ('$in_dir': $x, $y)\n"; last OUTER2; } print_array(@img); print "Points in CW order around the boundary:\n", pp(\@points_in_order), "\n"; 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; }

    ...roboticus

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

      Thanks, roboticus,

      I'm going to study your code, and I'll let you know how I fare. It's an interesting idea, that of tracking the current direction and then resolving to a "preferred" direction.

      Plus, I chuckled at your "I ignored your code. ...", followed by your disclaimer so I wouldn't feel bad. I'll sometimes do the same -- avoid reading the existing code so I don't get any preconceptions :-)

      say  substr+lc crypt(qw $i3 SI$),4,5
        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:

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

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (6)
As of 2020-11-24 22:00 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?