nirasan's tech blog

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

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

はじめに

前回の巡回セールスマン問題をPerlで - nirasan's tech blogで、巡回セールスマン問題の解法をPythonからPerlに移植しましたが、Tkまわりは省略しました。
今回はTkのインストールとTkまわりのコードを移植を行います。

Tkのインストール

下記コマンドでインストールします。
作業環境はUbuntuです。

sudo aptitude update
sudo aptitude install perl-tk

Tkの実行テスト

SYNOPSIS の通りに下記のコードを実行すると、空のウィンドウが表示されます。

use Tk;
$top = new MainWindow;
MainLoop;

欲張り法スクリプトのTk対応

  • draw, draw_path 関数を追加し、 main から呼び出すように変更しました。
#!/usr/bin/perl
use strict;
use warnings;
use Time::HiRes qw(gettimeofday tv_interval);
use Data::Dumper;
use Tk;
use List::Util qw(max);

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 draw {
    my ($path, $point_table) = @_;
    my $top = new MainWindow;

    my $max_x = max map { $point_table->[$_]->[0] } @$path;
    my $max_y = max map { $point_table->[$_]->[1] } @$path;
    my $canvas = $top->Canvas( -width => $max_x + 20, -height => $max_y + 20 )->pack();
    
    draw_path($canvas, $path, $point_table);

    MainLoop;
}

sub draw_path {
    my ($canvas, $path, $point_table) = @_;
    my ($x0, $y0) = ($point_table->[$path->[0]]->[0], $point_table->[$path->[0]]->[1]);
    for my $i (1 .. $#{$path}) {
        my $p = $point_table->[$i];
        my ($x1, $y1) = ($p->[0], $p->[1]);
        $canvas->createLine($x0, $y0, $x1, $y1);
        ($x0, $y0) = ($x1, $y1);
    }
    my $p0 = $point_table->[0];
    $canvas->createLine($x0, $y0, $p0->[0], $p0->[1]);
    for my $p (@$point_table) {
        my ($x, $y) = ($p->[0], $p->[1]);
        $canvas->createOval($x-4, $y-4, $x+4, $y+4, -fill => 'green' );
    }
}

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;

    draw($path, $point_table);
}

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

クラスカルのアルゴリズムの変形版スクリプトのTk対応

  • 同様に draw, draw_path 関数を追加し、 main から呼び出すように変更しました。
#!/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;
use Tk;
use List::Util qw(max);

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 draw {
    my ($select_edge, $point_table) = @_;
    my $top = new MainWindow;

    my $max_x = max map { $_->[0] } @$point_table;
    my $max_y = max map { $_->[1] } @$point_table;
    my $canvas = $top->Canvas( -width => $max_x + 20, -height => $max_y + 20 )->pack();
    
    draw_path($canvas, $select_edge, $point_table);

    MainLoop;
}

sub draw_path {
    my ($canvas, $select_edge, $point_table) = @_;
    for my $edge (@$select_edge) {
        my ($p1, $p2) = split /,/, $edge;
        my ($x0, $y0) = ($point_table->[$p1]->[0], $point_table->[$p1]->[1]);
        my ($x1, $y1) = ($point_table->[$p2]->[0], $point_table->[$p2]->[1]);
        $canvas->createLine($x0, $y0, $x1, $y1);
    }
    for my $p (@$point_table) {
        my ($x, $y) = ($p->[0], $p->[1]);
        $canvas->createOval($x-4, $y-4, $x+4, $y+4, -fill => 'green' );
    }
}

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;
    
    draw($select_edge, $point_table);
}

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