昨日の問題を遺伝的アルゴリズムっぽく
昨日の問題[1][2][3]を、遺伝的アルゴリズムのようなもので解いてみた。解くのに使ったPerlコードは最後に添付。
一応、前々回のエントリで提示したサンプルデータに対しては、10個の実験枠と40人の参加希望者を全て使い切る最適解を一つ見つけることができた。パラメータ変えながら50回くらい繰り返した末にだが。
とはいえ、実験枠数と参加希望者数の関係が変わったりするとまだうまく最適解を推測できないようなので、もう少しチューニングしたほうがよさそう。
最適解
前々回のエントリのサンプルデータの最適解の一つが↓。検証してないから正しいかどうかはわからないけどたぶん正しい。
[9, 2, 5, 0, 5, 0, 9, 8, 4, 7, 9, 1, 7, 7, 8, 6, 9, 4, 1, 2, 8, 0, 5, 1, 8, 3, 6, 2, 9, 4, 2, 3, 8, 4, 0, 3, 5, 4, 6, 2]
配列の各エントリーは参加希望者を表して、その値は割り当てられた実験枠の番号を表す。つまり、0番の参加者は9番の実験枠に割り当てられたということ。これで、実行可能な実験枠数が10個で参加可能な参加希望者数が40人。
コード
Perlで書いたコードが↓。もう少し工夫が必要。
use strict;
use Data::Dump 'dump';
use constant DEMAND => 3; #最少催行人数
use constant CAPACITY => 5; #最大収容人数
use constant G_SIZE => 512; #一世代の個体数
use constant G_COUNT => 16; #重ねる世代の数
use constant T_SIZE => 8; #トーナメントサイズ
use constant M_RATE => 0.2; #突然変異率
my $data = [[-1,0,1,2,3,5,6,8,9],[-1,0,2,3,5,7,8,9],[-1,1,2,3,4,5,7,8,9],[-1,0,2,3,5,8],[-1,0,1,5,8,9],[-1,0,2,5,8],[-1,0,3,9],[-1,2,3,6,7,8],[-1,1,4,5,6,8,9],[-1,0,2,3,4,5,6,7,9],[-1,1,4,6,8,9],[-1,0,1,2,4,6,8,9],[-1,1,2,3,4,6,7,8,9],[-1,2,6,7,8,9],[-1,0,1,2,3,5,8],[-1,2,5,6,9],[-1,0,1,3,5,6,7,8,9],[-1,0,4,9],[-1,1,2,3],[-1,1,2,7,8],[-1,1,8],[-1,0,2,3,4,6,7,9],[-1,4,5,7,8,9],[-1,1,2,3,6,7,8,9],[-1,0,4,6,7,8],[-1,0,1,2,3,4,5,6],[-1,0,2,4,6,8,9],[-1,2,9],[-1,0,2,3,5,6,9],[-1,0,1,2,3,4,5,7,9],[-1,1,2,4,9],[-1,0,1,2,3,6,7,8,9],[-1,1,2,5,8],[-1,0,3,4,6,8],[-1,0,3,4,5,6,8,9],[-1,0,1,3,4,8,9],[-1,0,2,4,5,6,8,9],[-1,0,1,4,5,6,7,8],[-1,0,1,4,6,7,8],[-1,1,2,7,9]];
# 適応度を評価する
# @param ArrayRef $genome
# @return ArrayRef 適応度 (実行可能枠数と参加可能人数)
sub evaluate($;) {
my ($genome, $programs, $fitness) = (shift, [], [0, 0]);
for (0..(@$data - 1)) {
$programs->[$genome->[$_]]++ if (-1 < $genome->[$_]);
}
for (0..(@$programs - 1)) {
if (DEMAND <= $programs->[$_] && $programs->[$_] <= CAPACITY) {
$fitness->[0]++;
$fitness->[1] += $programs->[$_];
}
}
return $fitness;
}
# 変異関数 (参加可能な枠のうちどれかを返す)
# @todo 実験枠数と希望者数を見て、-1を返す確率を変えたほうが良いかも。
# @param int $id 参加希望者番号
# @return int 参加可能枠のどれか一つの番号
sub mutate($;) {
$data->[$_[0]]->[int rand @{$data->[$_[0]]}];
}
# 交叉関数 (一様交叉でM_RATEの確率で変異)
# @param ArrayRef $genomeA
# @param ArrayRef $genomeB
# @return ArrayRef new genome
sub recombine($$;) {
my ($new, $tmp) = ([], (1 + M_RATE) / 2);
for (0..(@$data - 1)) {
my $rand = rand;
if ($rand < M_RATE) {
$new->[$_] = mutate $_;
} elsif ($rand < $tmp) {
$new->[$_] = $_[0]->[$_];
} else {
$new->[$_] = $_[1]->[$_];
}
}
return $new;
}
# トーナメント選択
# @param ArrayRef $generation
# @return ArrayRef the fittest genome
sub tSelect($;) {
my ($gen, $x, $y, $fittest) = (shift, -1, -1, []);
for (1..T_SIZE) {
my $id = int rand @{$gen};
my $fitness = $gen->[$id]->[1];
if ($x < $fitness->[0] && $y < $fitness->[1]) {
$x = $fitness->[0];
$y = $fitness->[1];
$fittest = $gen->[$id]->[0];
}
}
return $fittest;
}
# 世代の中で最もfitnessが高い個体を返す
# @param ArrayRef $generation
# @param ArrayRef the fittest individual
sub getFittest($;) {
my ($x, $y, $fittest) = (-1, -1, 0);
for (0..(@{$_[0]})) {
my $fitness = $_[0]->[$_]->[1];
if ($x < $fitness->[0] && $y < $fitness->[1]) {
$x = $fitness->[0];
$y = $fitness->[1];
$fittest = $_;
}
}
return $_[0]->[$fittest];
}
# generation = [individual, individual, ...]
# individual = [genome, fitness]
# genome = [希望者0の割り当て, 希望者1の割り当て, ...]
# fitness = [実行可能枠数, 参加可能人数]
#main-----
my ($current, $next) = ([], []);
#init
for my $i (0..(G_SIZE - 1)) {
my $genome = [];
for my $j (0..(@$data - 1)) {
$genome->[$j] = mutate $j;
}
$current->[$i] = [$genome, evaluate $genome];
}
#generations
for (0..(G_COUNT - 1)) {
$next = [getFittest $current]; #elite
for my $i (1..(G_SIZE - 1)) {
my $new = recombine tSelect($current), tSelect($current); #tournament
$next->[$i] = [$new, evaluate $new];
}
$current = $next;
}
#output
print dump getFittest $current;
工夫しなきゃいけないと思う点
- オブジェクト指向化して、パラメータやデータのべた書きは避ける
mutate()関数が-1を返す確率を調節する (実験枠数に対して参加希望者数が極端に多い場合や少ない場合にちゃんと推測できないから)evaluate()関数は差し替え可能に- 差し替え可能な
compareFitness()関数を作っていろいろな最適化方法に対応できるようにする
追記
Mishoが言うには、例のサンプルケースでは一瞬で最適解が出るらしい＞＜
本当に決定的アルゴリズムがあるのか？
っていうか問題の定義が自分でもわからなくなってきた＞＜
トラックバックURL
- http://liosk.blog103.fc2.com/tb.php/105-85c3fe08