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. | [reply] [Watch: Dir/Any] [d/l] |
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
| [reply] [Watch: Dir/Any] [d/l] [select] |
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;
}
}
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
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. | [reply] [Watch: Dir/Any] [d/l] [select] |
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. | [reply] [Watch: Dir/Any] [d/l] [select] |
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;
| [reply] [Watch: Dir/Any] [d/l] |
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...
| [reply] [Watch: Dir/Any] [d/l] [select] |
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]
| [reply] [Watch: Dir/Any] [d/l] |
|
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);
| [reply] [Watch: Dir/Any] [d/l] [select] |