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

reordering segments to form a polygon

by dada (Chaplain)
on Aug 13, 2004 at 09:15 UTC ( #382584=perlquestion: print w/replies, xml ) Need Help??

dada has asked for the wisdom of the Perl Monks concerning the following question:

hello,

I'm looking for a fast sorting (or "reordering") algorithm. the situation is as follows: I have a bunch of segments, in the form of 4-elements arrays ( START_X, START_Y, END_X, END_Y ). these segments form a polygon, but unfortunately I don't have them in the right order.

to let you understand the problem, consider this polygon:

| 5 + F-----------E | | | 4 + | | | | | 3 + | C--------D | | | 2 + | | | | | 1 + A--B | +--+--+--+--+--+-- 1 2 3 4 5
I could have the segments, for example, in this order (letters are not there, they're just for your reference):
DE = [ 5, 3, 5, 5 ] AB = [ 1, 1, 2, 1 ] BC = [ 2, 1, 2, 3 ] EF = [ 5, 5, 1, 5 ] FA = [ 1, 5, 1, 1 ] CD = [ 2, 3, 5, 3 ]
and I need them in this order:
AB = [ 1, 1, 2, 1 ] BC = [ 2, 1, 2, 3 ] CD = [ 2, 3, 5, 3 ] DE = [ 5, 3, 5, 5 ] EF = [ 5, 5, 1, 5 ] FA = [ 1, 5, 1, 1 ]
in fact, what I need is just the order of the points to build the polygon, which is:
A = [ 1, 1 ] B = [ 2, 1 ] C = [ 2, 3 ] D = [ 5, 3 ] E = [ 5, 5 ] F = [ 1, 5 ]
that said, the algorithm I came up with is:
# segments are in @seg my($start_x, $start_y) = ($seg[0]->[0], $seg[0]->[1]); my($end_x, $end_y) = ($seg[0]->[2], $seg[0]->[3]); push(@poly, [$start_x, $start_y]); push(@poly, [$end_x, $end_y]); shift(@seg); while(@seg) { for(my $s = 0; $s <= $#seg; $s++) { if( $seg[$s]->[0] == $end_x and $seg[$s]->[1] == $end_y ) { ($end_x, $end_y) = ($seg[$s]->[2], $seg[$s]->[3]); push(@poly, [$end_x, $end_y]); splice(@seg, $s, 1); } } } # polygon points are in @poly
this actually works, but since I have several hundreds of thousands of points to reorder, I really need something more efficient. I'm pretty sure I have to use a hash somehow, but my brain, or at least part of it, seems to be gone in vacation :-)

well, if your brain is still around, can you help me?

cheers,
Aldo

King of Laziness, Wizard of Impatience, Lord of Hubris

Replies are listed 'Best First'.
Re: reordering segments to form a polygon
by Corion (Patriarch) on Aug 13, 2004 at 09:41 UTC

    Your problem description is a bit vague, or rather, I see a problem with the direction of the lines. If you can guarantee that all lines will be clockwise (or counterclockwise), then my approach will work. If you cannot guarantee that, or a point has more than one line ending or starting at it, you will need to modify the algorithm to use two hashes or to record both directions of each line.

    The basic idea is as follow:

    Currently, you are rescanning the whole list of lines every time you want to add a new point to your polygon. My approach is to scan the whole list two times. In the first pass, you record every line in a hash, mapping the start point to its end point. In the second pass, you iterate through the hash from any point, and follow wherever the value of that point leads (as a key in the hash).

    my %end_point; # First, scan the list for all start points: foreach my $line (@seg) { my $start = join "|", $line->[0], $line->[1]; my $end = join "|", $line->[2], $line->[3]; die "Point ($start) has more than one line starting at it: ($start) +-> ($end_point{$start}) and ($start) -> ($end)" if $start_point{$start}; $end_point{$start} = $end; }; # Now, jut select an arbitrary point, and trace our # polygon. If there are keys left after the target # of our current point does not exist anymore, the list # of points does not describe one closed polygon my $start = join "|", $seq[0]->[0], $seq[0]->[1]; my $cur = $start; while (exists $end_point{$cur}) { print "($cur) -> $end_point{$cur}\n"; $cur = delete $end_point{$cur}; }; if (keys %end_point) { warn "The list did not describe one closed polygon:\n"; warn "Started at ($start), got to ($cur)\n"; warn "Left over vertices:\n"; warn "$_ -> $end_point{$_}\n" for (keys %end_point); die "Error in polygon list"; };

    The code is untested, but I guess that's the closest you'll get with an unsorted list. If your list is (partially) sorted in a good way, you might be able to skip the first scan which creates the lookup hash. It also might be faster to use a multi-dimensional hash depending on $;, but I prefer to build the hash keys myself.

Re: reordering segments to form a polygon
by Jaap (Curate) on Aug 13, 2004 at 10:06 UTC
    I guess this would be the hash approach you speak of:
    #!/cadappl/bin/perl -w -Ilib use strict; use Data::Dumper; my @r = ( [ 5, 3, 5, 5 ], [ 1, 1, 2, 1 ], [ 2, 1, 2, 3 ], [ 5, 5, 1, 5 ], [ 1, 5, 1, 1 ], [ 2, 3, 5, 3 ] ); my %lineTo; foreach my $ref (@r) { $lineTo{"$$ref[0],$$ref[1]"} = "$$ref[2],$$ref[3]"; } my $start = "1,1"; my $curr = $start; print "$curr\n"; while (($curr = $lineTo{$curr}) ne $start) { print "$curr\n"; }
    Output:
    1,1 2,1 2,3 5,3 5,5 1,5
Re: reordering segments to form a polygon
by borisz (Canon) on Aug 13, 2004 at 09:44 UTC
    perhaps this suits your needs?
    use Data::Dumper; my @r = ( [ 5, 3, 5, 5 ], [ 1, 1, 2, 1 ], [ 2, 1, 2, 3 ], [ 5, 5, 1, 5 ], [ 1, 5, 1, 1 ], [ 2, 3, 5, 3 ] ); @x = sort { $a->[2] <=> $b->[0] || $a->[3] <=> $b->[1] || -1 } @r; print Dumper(\@x); __OUTPUT__ [ 1, 5, 1, 1 ] [ 1, 1, 2, 1 ] [ 2, 1, 2, 3 ] [ 2, 3, 5, 3 ] [ 5, 3, 5, 5 ] [ 5, 5, 1, 5 ]
    Update: As Jaap found out, it did not work always, so here is my next try:
    for my $i (0..$#r) { my $p = $i + 1; for my $j ($p .. $#r) { next unless $r[$i]->[2] == $r[$j]->[0] && $r[$i]->[3] == $r[$j]->[1]; @r[$p, $j] = @r[$j, $p]; last; } }
    Boris
      Although VERY beautiful, it is incorrect:
      #!/cadappl/bin/perl -w -Ilib use strict; my @r = ( [ 5, 3, 5, 5 ], [ 1, 1, 2, 1 ], [ 2, 3, 5, 3 ], [ 5, 5, 1, 5 ], [ 2, 1, 2, 3 ], [ 1, 5, 1, 1 ], ); my @x = sort { $a->[2] <=> $b->[0] || $a->[3] <=> $b->[1] || -1 } @r; foreach (@x) { print "$_->[0],$_->[1],$_->[2],$_->[3]\n"; }
      Output:
      1,5,1,1 1,1,2,1 2,1,2,3 5,5,1,5 2,3,5,3 5,3,5,5
      I changed the order of @r to show the error.
Re: reordering segments to form a polygon
by Random_Walk (Prior) on Aug 13, 2004 at 10:42 UTC
    someone beat me to it but I coded it so I might as well post it.
    #!/usr/local/bin/perl -w use strict; my @seg = ( [ 1, 1, 2, 1 ], [ 5, 5, 1, 5 ], [ 2, 3, 5, 3 ], [ 5, 3, 5, 5 ], [ 2, 1, 2, 3 ], [ 1, 5, 1, 1 ]); my ( $i, $end, $start, %polygon )=(-1, ""); foreach (@seg) { $i++; $start = $_->[0] ." ". $_->[1]; $polygon{$start} = $i; } while ( ($end=$seg[$i]->[2]." ".$seg[$i]->[3]) ne $start) { print "$seg[$i]->[0] $seg[$i]->[1] $end\n"; $i = $polygon{$end}; } print "$seg[$i]->[0] $seg[$i]->[1] $end\n";
    This will not play nice if your polygon is not closed.
    Cheers,

    code seriously tidied up, posted too hastily. The print can be replaced with a push of $seg[$i] onto a new ordered array for use as a sub of other code.

    Thought I'd add a quick comment on how it works

    The first loop reads each element of the array and records its index number in a hash keyed by starting point.
    The second loop starts with the last array element processed, reads it's end from the array and then looks into the hash to find the index of the array element starting there, This index it uses to find the end of that line
    Rinse repeat until the end is where we started.

Re: reordering segments to form a polygon
by fletcher_the_dog (Friar) on Aug 13, 2004 at 14:12 UTC
    Slight variations on what other have done. This dies if your polygon is not closed.
    #!/usr/bin/perl use strict; my @seg = ( [ 1, 1, 2, 1 ], [ 5, 5, 1, 5 ], [ 2, 3, 5, 3 ], [ 5, 3, 5, 5 ], [ 2, 1, 2, 3 ], [ 1, 5, 1, 1 ]); my %starts=map{"@$_[0,1]",$_} @seg; my @sorted_segs = my $cur = $seg[0]; while (1) { my $next = $starts{"@$cur[2,3]"}; die "your polygon is broken\n" if !$next; $next==$seg[0] ? last : push @sorted_segs,$next; $cur = $next; } print "@$_\n" for @sorted_segs;
Re: reordering segments to form a polygon
by fergal (Chaplain) on Aug 13, 2004 at 16:52 UTC
    Here's a version that only requires a single pass over the array. The end result is that the 5th element of each segment is a ref to the next one. The last one doesn't reference the next or we'd get a circular structure.
    use warnings; use strict; my @seg = ( [ 1, 1, 2, 1 ], [ 5, 5, 1, 5 ], [ 2, 3, 5, 3 ], [ 5, 3, 5, 5 ], [ 2, 1, 2, 3 ], [ 1, 5, 1, 1 ] ); use Data::Dumper qw(Dumper); my (%have, %want); while (my $seg = shift @seg) { my $have = join(",", @{$seg}[0,1]); my $want = join(",", @{$seg}[2,3]); print "we have $have\n"; if (my $wanted = delete $want{$have}) { print "something wants it\n"; $wanted->[4] = $seg; } else { print "nothing wants it yet\n"; $have{$have} = $seg; } last if @seg == 0; # don't want to make a circular reference print "we want $want\n"; if (my $had = delete $have{$want}) { print "found it\n"; $seg->[4] = $had; } else { print "didn't find it, asking for it\n"; $want{$want} = $seg; } } $Data::Dumper::Indent = 0; print Dumper values %have;
    the end result is
    [1,1,2,1,[2,1,2,3,[2,3,5,3,[5,3,5,5,[5,5,1,5,[1,5,1,1]]]]]]
    It's glorious day in Dublin so I'm off to the pub now :-)

    UpdateI suppose it does require a second pass to produce output in the format requested...

Re: reordering segments to form a polygon
by johnnywang (Priest) on Aug 13, 2004 at 18:11 UTC
    Just tidy up what others have done, especially the non-closed situation.
    use strict; my @seg = ( [ 1, 1, 2, 1 ], [ 5, 5, 1, 5 ], [ 2, 3, 5, 3 ], [ 5, 3, 5, 5 ], [ 2, 1, 2, 3 ], [ 1, 5, 1, 1 ]); my %pairs = map{("[$_->[0],$_->[1]]","[$_->[2],$_->[3]]")} @seg; my $start = "[1,1]"; my $current = $start; do{ print $current,"\n"; $current = $pairs{$current}; }while(defined $pairs{$current} && $current ne $start) __OUTPUT__ [1,1] [2,1] [2,3] [5,3] [5,5] [1,5]
      I independantly came up with the same thing! but since mine doesn't assume 1,1 exists and since mine detects unconnected polygons, I'll post it.
      # -- input -- my @r = ( [ 5, 3 => 5, 5 ], [ 1, 1 => 2, 1 ], [ 2, 1 => 2, 3 ], [ 5, 5 => 1, 5 ], [ 1, 5 => 1, 1 ], [ 2, 3 => 5, 3 ], ); # -- work -- %lookup = map { join(',', $_->[0], $_->[1]) => join(',', $_->[2], $_-> +[3]) } @r; $start = $next = (sort(keys(%lookup)))[0]; #$start = $next = (keys(%lookup))[0]; do { push(@x, [ split(/\,/, $next) ]); $next = $lookup{$next}; die("broken!\n") unless defined($next); } while ($next ne $start); # -- output -- printf("[ %d, %d ]\n", @$_) foreach (@x); __END__ output: [ 1, 1 ] [ 2, 1 ] [ 2, 3 ] [ 5, 3 ] [ 5, 5 ] [ 1, 5 ] time complexity: O(n) (without the unneccesary sort)
      One thing it doesn't do is detects dots used more than once, so let's fix that:
      %lookup = map { join(',', $_->[0], $_->[1]) => join(',', $_->[2], $_-> +[3]) } @r; $start = $next = (sort(keys(%lookup)))[0]; #$start = $next = (keys(%lookup))[0]; do { $current = $next; push(@x, [ split(/,/, $current) ]); $next = $lookup{$current}; delete($lookup{$current}); die("broken or repeat!\n") unless defined($next); } while ($next ne $start);

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://382584]
Approved by Corion
Front-paged by broquaint
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (5)
As of 2022-09-28 08:34 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    I prefer my indexes to start at:




    Results (124 votes). Check out past polls.

    Notices?