Algorithm-TravelingSalesman-BitonicTour
view release on metacpan or search on metacpan
* added further input checking plus tests
* fixed bug in example code
0.02 Thu May 15 14:28:59 CDT 2008
* added path calculation
* 100% test coverage
* fixed problem documentation
0.01 Thu Feb 21 09:15:57 CST 2008
* initial release
* basic functionality--can calculate optimal path lengths
example/cb.pl view on Meta::CPAN
# in any order; these just happen to be left-to-right.
$b->add_point(0,6);
$b->add_point(1,0);
$b->add_point(2,3);
$b->add_point(5,4);
$b->add_point(6,1);
$b->add_point(7,5);
$b->add_point(8,2);
my ($length, @tour) = $b->solve;
print "length of optimal bitonic tour: $length\n";
print "points in optimal bitonic tour:\n";
print " (@$_)\n" for @tour;
lib/Algorithm/TravelingSalesman/BitonicTour.pm view on Meta::CPAN
use Algorithm::TravelingSalesman::BitonicTour;
my $bt = Algorithm::TravelingSalesman::BitonicTour->new;
$bt->add_point($x1,$y1);
$bt->add_point($x2,$y2);
$bt->add_point($x3,$y3);
# ...add other points as needed...
# get and print the solution
my ($len, @coords) = $bt->solve;
print "optimal path length: $len\n";
print "coordinates of optimal path:\n";
print " ($_->[0], $_->[1])\n" for @coords;
=head1 THE PROBLEM
From I<Introduction to Algorithms>, 2nd ed., T. H. Cormen, C. E. Leiserson, R.
Rivest, and C. Stein, MIT Press, 2001, problem 15-1, p. 364:
=over 4
lib/Algorithm/TravelingSalesman/BitonicTour.pm view on Meta::CPAN
An open bitonic tour, optimal or not, has these properties:
* it's bitonic (a vertical line crosses the tour at most twice)
* it's open (it has endpoints), which we call "i" and "j" (i < j)
* all points to the left of "j" are visited by the tour
* points i and j are endpoints (connected to exactly one edge)
* all other points in the tour are connected to two edges
For a given set of points there may be many open bitonic tours with endpoints
(i,j), but we are only interested in the I<optimal> open tour--the tour with
the shortest length. Let's call this tour B<C<T(i,j)>>.
=item 2. Grok the (slightly) messy recurrence relation.
A concrete example helps clarify this. Assume we know the optimal tour lengths
for all (i,j) to the right of point C<5>:
T(0,1)
T(0,2) T(1,2)
T(0,3) T(1,3) T(2,3)
T(0,4) T(1,4) T(2,4) T(3,4)
From this information, we can find C<T(0,5)>, C<T(1,5)>, ... C<T(4,5)>.
=over 4
lib/Algorithm/TravelingSalesman/BitonicTour.pm view on Meta::CPAN
These exercises may clarify the above analysis.
=over 4
=item Exercise 1.
Consider the parallelogram ((0,0), (1,1), (2,0), (3,1)).
a. Draw it on graph paper.
b. Label points "0" through "3"
c. Draw t[0,1]. Calculate its length.
d. Draw t[0,2] and t[1,2]. Calculate their lengths.
e. Draw t[0,3], t[1,3], and t[2,3]. Calculate their lengths.
f. What is the optimal bitonic tour?
g. Draw the suboptimal bitonic tour.
h. Why does the above algorithm find the optimal tour,
and not the suboptimal tour?
=item Exercise 2.
Repeat Exercise 1 with pentagon ((0,2), (1,0), (2,3), (3,0), (4,2)).
=back
lib/Algorithm/TravelingSalesman/BitonicTour.pm view on Meta::CPAN
=cut
sub coord {
my ($self, $n) = @_;
return @{ ($self->sorted_points)[$n] };
}
=head2 $ts->solve()
Solves the problem as configured. Returns a list containing the length of the
minimum tour, plus the coordinates of the points in the tour in traversal
order.
Example:
my ($length, @points) = $ts->solve();
print "length: $length\n";
for (@points) {
my ($x,$y) = @$_;
print "($x,$y)\n";
}
=cut
sub solve {
my $self = shift;
my ($length, @points);
if ($self->N < 1) {
die "ERROR: you need to add some points!";
}
elsif ($self->N == 1) {
($length, @points) = (0,0);
}
else {
($length, @points) = $self->optimal_closed_tour;
}
my @coords = map { [ $self->coord($_) ] } @points;
return ($length, @coords);
}
=head2 $ts->optimal_closed_tour
Find the length of the optimal complete (closed) bitonic tour. This is done by
choosing the shortest tour from the set of all possible complete tours.
A possible closed tour is composed of a partial tour with rightmost point C<R>
as one of its endpoints plus the final return segment from R to the other
endpoint of the tour.
T(0,R) + delta(0,R)
T(1,R) + delta(1,R)
...
T(i,R) + delta(i,R)
...
T(R-1,R) + delta(R-1,R)
=cut
sub optimal_closed_tour {
my $self = shift;
$self->populate_open_tours;
my $R = $self->R;
my @tours = map {
my $cost = $self->tour_length($_,$self->R) + $self->delta($_,$self->R);
my @points = ($self->tour_points($_,$R), $_);
[ $cost, @points ];
} 0 .. $self->R - 1;
my $tour = reduce { $a->[0] < $b->[0] ? $a : $b } @tours;
return @$tour;
}
=head2 $ts->populate_open_tours
Populates internal data structure C<tour($i,$j)> describing all possible
optimal open tour costs and paths for this problem configuration.
=cut
sub populate_open_tours {
my $self = shift;
# Base case: tour(0,1) has to be the segment (0,1). It would be nice if
# the loop indices handled this case correctly, but they don't.
$self->tour_length(0, 1, $self->delta(0,1) );
$self->tour_points(0, 1, 0, 1);
# find optimal tours for all points to the left of 2, 3, ... up to R
foreach my $k (2 .. $self->R) {
# for each point "i" to the left of "k", find (and save) the optimal
# open bitonic tour from "i" to "k".
foreach my $i (0 .. $k - 1) {
my ($len, @points) = $self->optimal_open_tour($i,$k);
$self->tour_length($i, $k, $len);
$self->tour_points($i, $k, @points);
}
}
}
=head2 $ts->optimal_open_tour($i,$j)
Determines the optimal open tour from point C<$i> to point C<$j>, based on the
values of previously calculated optimal tours to the left of C<$j>.
As discussed above, there are two distinct cases for this calculation: when C<<
$i == $j - 1 >> and when C<< $i < $j - 1 >>.
# determine the length of and points in the tour
# starting at point 20 and ending at point 25
my ($length,@points) = $ts->optimal_open_tour(20,25);
=cut
sub optimal_open_tour {
my ($self, $i, $j) = @_;
local $" = q(,);
# we want $i to be strictly less than $j (we can actually be more lax with
# the inputs, but this stricture halves our storage needs)
croak "ERROR: bad call, optimal_open_tour(@_)" unless $i < $j;
lib/Algorithm/TravelingSalesman/BitonicTour.pm view on Meta::CPAN
$j - 1 >>. In this case there are many possible bitonic tours, all going from
C<$i> to "C<$x>" to C<$j>. All points C<$x> in the range C<(0 .. $i - 1)> are
examined to find the optimal tour.
=cut
sub optimal_open_tour_adjacent {
my ($self, $i, $j) = @_;
my @tours = map {
my $x = $_;
my $len = $self->tour_length($x,$i) + $self->delta($x,$j);
my @path = reverse($j, $self->tour_points($x, $i) );
[ $len, @path ];
} 0 .. $i - 1;
my $min_tour = reduce { $a->[0] < $b->[0] ? $a : $b } @tours;
return @$min_tour;
}
=head2 $obj->optimal_open_tour_nonadjacent($i,$j)
Uses information about optimal open tours to the left of <$j> to find the
optimal tour with endpoints (C<$i>, C<$j>).
This method handles the case where C<$i> and C<$j> are not adjacent, i.e. C<<
$i < $j - 1 >>. In this case there is only one bitonic tour possible, going
from C<$i> to C<$j-1> to C<$j>.
=cut
sub optimal_open_tour_nonadjacent {
my ($self, $i, $j) = @_;
my $len = $self->tour_length($i, $j - 1) + $self->delta($j - 1,$j);
my @points = ($self->tour_points($i, $j - 1), $j);
return($len, @points);
}
=head2 $b->tour($i,$j)
Returns the data structure associated with the optimal open bitonic tour with
endpoints (C<$i>, C<$j>).
lib/Algorithm/TravelingSalesman/BitonicTour.pm view on Meta::CPAN
sub tour {
my ($self, $i, $j) = @_;
croak "ERROR: tour($i,$j) ($i >= $j)"
unless $i < $j;
croak "ERROR: tour($i,$j,...) ($j >= @{[ $self->N ]})"
unless $j < $self->N;
$self->_tour->{$i}{$j} = [] unless $self->_tour->{$i}{$j};
return $self->_tour->{$i}{$j};
}
=head2 $b->tour_length($i, $j, [$len])
Returns the length of the optimal open bitonic tour with endpoints (C<$i>,
C<$j>). If C<$len> is specified, set the length to C<$len>.
=cut
sub tour_length {
my $self = shift;
my $i = shift;
my $j = shift;
if (@_) {
croak "ERROR: tour_length($i,$j,$_[0]) has length <= 0 ($_[0])"
unless $_[0] > 0;
$self->tour($i,$j)->[0] = $_[0];
}
if (exists $self->tour($i,$j)->[0]) {
return $self->tour($i,$j)->[0];
}
else {
croak "Don't know the length of tour($i,$j)";
}
}
=head2 $b->tour_points($i, $j, [@points])
Returns an array containing the indices of the points in the optimal open
bitonic tour with endpoints (C<$i>, C<$j>).
If C<@points> is specified, set the endpoints to C<@points>.
t/02-optimal-tours.t view on Meta::CPAN
# set up a problem and do some basic sanity checking
my $b = Algorithm::TravelingSalesman::BitonicTour->new;
$b->add_point(0,0);
$b->add_point(1,1);
$b->add_point(2,1);
$b->add_point(3,0);
is($b->N, 4);
is_deeply( [$b->sorted_points], [[0,0], [1,1], [2,1], [3,0]] );
# optimal open tours aren't populated yet...
throws_ok { $b->tour_length(1,2) } qr/Don't know the length/, 'die on unpopulated tour length';
throws_ok { $b->tour_points(1,2) } qr/Don't know the points/, 'die on unpopulated tour points';
# make sure population with bad endpoints is caught...
throws_ok { $b->tour_points(1,2,0,1,2) } qr/ERROR/, 'die on bad endpoints';
throws_ok { $b->tour_points(1,2,1,2,3) } qr/ERROR/, 'die on bad endpoints';
throws_ok { $b->tour_points(1,2,1,2) } qr/ERROR/, 'die on wrong number of points';
# populate the optimal open tours
$b->populate_open_tours;
#diag(Dumper($b));
# make sure invalid tour queries throw an exception
throws_ok { $b->tour(1,0) } qr/ERROR/, 'die on invalid tour limits';
throws_ok { $b->tour_length(42,142) } qr/ERROR/, 'die on invalid length limits';
throws_ok { $b->tour_length(0,1,-1) } qr/ERROR/, 'die on invalid length';
throws_ok { $b->optimal_open_tour(1,0) } qr/ERROR/, 'die on invalid tour limits';
throws_ok { $b->optimal_open_tour(1.5,2) } qr/ERROR/, 'die on invalid tour limits';
{
my @tour = $b->optimal_open_tour(1,2);
is (sprintf('%.2f',$tour[0]), 3.65);
}
{
my @tour = $b->optimal_open_tour(0,2);
is (sprintf('%.3f',$tour[0]), 2.414);
t/02-optimal-tours.t view on Meta::CPAN
{
my @tests = (
[ 0,1 => 1.41 => 0, 1 ],
[ 0,2 => 2.41 => 0, 1, 2 ],
[ 0,3 => 3.83 => 0, 1, 2, 3 ],
[ 1,2 => 3.65 => 1, 0, 2 ],
[ 1,3 => 5.06 => 1, 0, 2, 3 ],
[ 2,3 => 5.41 => 2, 1, 0, 3 ],
);
my $c = sub { 0 + sprintf('%.2f', $b->tour_length(@_)) };
my $p = sub { [ $b->tour_points(@_) ] };
foreach my $t (@tests) {
my ($i, $j, $length, @points) = @$t;
is( $c->($i,$j), $length);
is_deeply( $p->($i, $j), \@points);
}
}
t/13-solve-4.t view on Meta::CPAN
use_ok('Algorithm::TravelingSalesman::BitonicTour');
# solve a real problem (simple trapezoid)
{
my $b = Algorithm::TravelingSalesman::BitonicTour->new;
$b->add_point(0,0);
$b->add_point(1,1);
$b->add_point(2,1);
$b->add_point(3,0);
my ($length, @points) = $b->solve;
is(sprintf('%.3f', $length), 6.828, 'known correct length');
my $points = do {
my @p = map "[@$_[0],@$_[1]]", @points[ 0 .. $#points - 1 ];
join q( ), @p, @p;
};
my $correct_re = do {
my @correct = map quotemeta, ('[0,0]','[1,1]','[2,1]','[3,0]');
my $pat = "@correct|@{[ reverse @correct ]}";
qr/$pat/;
};
like($points, $correct_re);
#diag "length=$length";
#diag Dumper(@points);
}
t/14-solve-N.t view on Meta::CPAN
Readonly::Scalar my $N => 201; # number of points
use_ok('Algorithm::TravelingSalesman::BitonicTour');
# Solve a problem consisting of some large number of points evenly spaced along
# the circumference of the unit circle. The distance should be roughly 2 * pi.
{
my $b = Algorithm::TravelingSalesman::BitonicTour->new;
$b->add_point(@$_) for points();
my ($length, @points) = $b->solve;
is(
sprintf('%.3f', $length),
sprintf('%.3f', 2 * $pi),
'circumference of the unit circle equals 2 * pi'
);
my $points = do {
my @p = map "[@$_[0],@$_[1]]", @points[ 0 .. $#points - 1 ];
join q( ), @p, @p;
};
my $correct_re = do {
( run in 0.287 second using v1.01-cache-2.11-cpan-65fba6d93b7 )