nirasan's tech blog

趣味や仕事の覚え書きです。Linux, Perl, PHP, Ruby, Javascript, Android, Cocos2d-x, Unity などに興味があります。

巡回セールスマン問題をPerlで

はじめに

巡回セールスマン問題の解法をPythonで解説しているサイトがあったので、Perlに移植してみたメモ。

「TSP を「欲張り法」で解く」をPerl

  • Tkまわりは省略
  • 割とそのまま移植できた
  • 実行結果も元サイトの通りになった
#!/usr/bin/perl
use strict;
use warnings;
use Time::HiRes qw(gettimeofday tv_interval);
use Data::Dumper;

sub read_data {
    my $buff = [];
    while (my $line = <STDIN>) {
        my @vals = split /\s+/, $line;
        push @$buff, \@vals;
    }
    return $buff;
}

sub distance {
    my $ps = shift; # [ [x, y], .. ]
    my $max = $#{$ps};
    my $table = [ map { [0] } @$ps ];
    for my $i (0..$max) {
        for my $j (0..$max) {
            if ($i != $j) {
                my $dx = $ps->[$i]->[0] - $ps->[$j]->[0];
                my $dy = $ps->[$i]->[1] - $ps->[$j]->[1];
                $table->[$i]->[$j] = sqrt($dx ** 2 + $dy ** 2);
            }
        }
    }
    return $table;
}

sub path_length {
    my ($path, $distance_table) = @_;
    my $n = 0;
    for my $i (1..$#{$path}) {
        $n += $distance_table->[$path->[$i - 1]]->[$path->[$i]];
    }
    $n += $distance_table->[$path->[0]]->[$path->[-1]];
    return $n;
}

sub greedy0 {
    my ($size, $distance_table) = @_;
    my @path = (0 .. $size-1);
    for my $i (0 .. $size-2) {
        my $min_len = 1000000;
        my $min_pos = 0;
        for my $j ($i+1 .. $size-1) {
            my $len = $distance_table->[$path[$i]]->[$path[$j]];
            if ($len < $min_len) {
                $min_len = $len;
                $min_pos = $j;
            }
        }
        ($path[$i + 1], $path[$min_pos]) = ($path[$min_pos], $path[$i + 1]);
    }
    return \@path;
}

sub main {
    my $start = [gettimeofday];

    my $point_table = read_data();
    my $point_size = scalar(@$point_table);
    my $distance_table = distance($point_table);

    my $path = greedy0($point_size, $distance_table);
    my $path_len = path_length($path, $distance_table);
    
    my $end = [gettimeofday];
    my $spend = tv_interval $start, $end;

    print Dumper $path;
    printf "\nlen:%d\ntime:%s\n", $path_len, $spend;
}

main();

__END__

=head1 USAGE

 perl SCRIPT_NAME < DATA_FILE

=head1 DATA FILE FORMAT

 position1 [space] position2

=head1 DATA FILE EXAMPLE

 20  20
 120 20
 220 20
 70  120
 170 120
 270 120
 20  220
 120 220

「クラスカルのアルゴリズムの変形版で解く」をPerl

  • Tkまわりは省略
  • PQueue を List::PriorityQueue で置き換えた(要インストール)
  • UnionFind を Graph::UnionFind で置き換えた(要インストール)
  • 変更した部分の影響か、元サイトよりも若干結果が悪くなった
#!/usr/bin/perl
use strict;
use warnings;
use lib "./extlib/lib/perl5/";

use Time::HiRes qw(gettimeofday tv_interval);
use Data::Dumper;
use List::PriorityQueue;
use Graph::UnionFind;

sub read_data {
    my $buff = [];
    while (my $line = <STDIN>) {
        my @vals = split /\s+/, $line;
        push @$buff, \@vals;
    }
    return $buff;
}

sub distance {
    my $ps = shift; # [ [x, y], .. ]
    my $max = $#{$ps};
    my $table = [ map { [0] } @$ps ];
    for my $i (0..$max) {
        for my $j (0..$max) {
            if ($i != $j) {
                my $dx = $ps->[$i]->[0] - $ps->[$j]->[0];
                my $dy = $ps->[$i]->[1] - $ps->[$j]->[1];
                $table->[$i]->[$j] = sqrt($dx ** 2 + $dy ** 2);
            }
        }
    }
    return $table;
}

sub path_length {
    my ($select_edge, $distance_table) = @_;
    my $n = 0;
    for my $edge (@$select_edge) {
        my ($p1, $p2) = split /,/, $edge;
        $n += $distance_table->[$p1]->[$p2];
    }
    return $n;
}

sub make_edge {
    my ($size, $distance_table) = @_;
    my $edges = new List::PriorityQueue;
    for my $i (0 .. $size-2) {
        for my $j ($i+1 .. $size-1) {
            my $edge = sprintf "%d,%d", $i, $j;
            my $priority = $distance_table->[$i]->[$j];
            $edges->insert($edge, $priority);
        }
    }
    return $edges;
}

sub greedy1 {
    my ($size, $edges) = @_;
    
    my @edge_count = map { 0 } (0 .. $size-1);
    
    my $u = Graph::UnionFind->new;
    for my $n (0 .. $size-1) {
        $u->add($n);
    }
    
    my $i = 0;
    my @select_edge;
    while ($i < $size) {
        my $edge = $edges->pop();
        my ($p1, $p2) = split /,/, $edge;
        if (
            $edge_count[$p1] < 2 &&
            $edge_count[$p2] < 2 &&
            ( $u->find($p1) != $u->find($p2) || $i == $size -1 )
        ) {
            $u->union($p1, $p2);
            $edge_count[$p1] += 1;
            $edge_count[$p2] += 1;
            push @select_edge, $edge;
            $i += 1;
        }
    }
    return \@select_edge;
}

sub main {
    my $start = [gettimeofday];

    my $point_table = read_data();
    my $point_size = scalar(@$point_table);
    my $distance_table = distance($point_table);

    my $edges = make_edge($point_size, $distance_table);
    my $select_edge = greedy1($point_size, $edges);
    my $path_len = path_length($select_edge, $distance_table);
    
    my $end = [gettimeofday];
    my $spend = tv_interval $start, $end;

    print Dumper $select_edge;
    printf "\nlen:%d\ntime:%s\n", $path_len, $spend;
}

main();

__END__

=head1 USAGE

 perl SCRIPT_NAME < DATA_FILE

=head1 DEPENDENCY LIBRARY INATALL

 cpanm -l ./extlib List::PriorityQueue
 cpanm -l ./extlib Graph::UnionFind

=head1 DATA FILE FORMAT

 position1 [space] position2

=head1 DATA FILE EXAMPLE

 20  20
 120 20
 220 20
 70  120
 170 120
 270 120
 20  220
 120 220