求精简和修改perl6写的遗传算法GA
本帖最后由 aef25u 于 2020-01-06 19:21 编辑仿照python用perl6实现了最简单的遗传算法，但感觉臃肿，请大牛帮精简或改写地更perler一些，只改部分代码均行。
其中：1、dot函数自已实现的只适用简单情况，不知perl6有没有现成的或哪个模块能提供?
2、np.random.choice（python版函数），我用自己想的方法进行模拟（位于select()函数内），求改写地更简洁或更好的版本
my @p=@fitness.map: {$_/sum(@fitness)};
my %h=(0..@p.elems-1).map: {$_=>($POP_SIZE* @p[$_]*10).round(1)+1};
my @sample;
for %h.kv -> $key, $value {
#say("$key=>$value");
push(@sample,$key) for (1..$value);
}
my @samshuffle=@sample.sort: { rand };
my @idx = @samshuffle.roll($POP_SIZE);
my $DNA_SIZE = 10; # DNA 长度
my $POP_SIZE = 100; # 种群总数
my $CROSS_RATE = 0.8; # 交叉配对比率 (DNA crossover)
my $MUTATION_RATE = 0.003; # 变异率 mutation probability
my $N_GENERATIONS = 200; # 繁殖代数
my @X_BOUND = (0, 5); # x坐标范围
sub dot(@a,@b) {
fail "Vector @a length not equal to @b!" unless +@a == +@b;
my @c = @a <<*>> @b;
}
# 查找某函数在X_BOUND范围内的最大值
sub F(@x) {return @x.map:{sin(10*$_)*$_ + cos(2*$_)*$_}}
#适应度函数（y值占所有y值合计的占比越大越有优势）
#如果函数会产生负值，将横坐标轴下移，令所有y值均大于0，
#因遗传选择时select（），@p=@fitness.map: {$_/sum(@fitness)};不能为负值且分母不能为0
sub get_fitness(@pred) { return @pred.map: {$_ + 1e-3 - min(@pred)}}
# DNA翻译规则：即x，二进制表示的DNA转为十进制，并将其归一化至(0, 5)
sub translateDNA(@pop){return @pop.map: { [+](dot($_,(0..^$DNA_SIZE).reverse.map: { 2** $_} )) / (2**$DNA_SIZE-1)*@X_BOUND}}
#遗传选择函数，适者生存，不适者淘汰
#按编号返回优势者个体列表；$p参数：表示选择标准（此例中按照比例来选择，适应度得分高的p有越大的概率被留下来）
sub select(@pop, @fitness){
my @p=@fitness.map: {$_/sum(@fitness)};
my %h=(0..@p.elems-1).map: {$_=>($POP_SIZE* @p[$_]*10).round(1)+1};
my @sample;
for %h.kv -> $key, $value {
#say("$key=>$value");
push(@sample,$key) for (1..$value);
}
my @samshuffle=@sample.sort: { rand };
my @idx = @samshuffle.roll($POP_SIZE);
return @pop[@idx];
}
#繁衍，优势个体作为父亲，按交叉配对比率CROSS_RATE在优势种群中选择母亲，生成小孩
sub crossover($parent, @pop) {
if (rand <$CROSS_RATE) {
my $i=(0..^$POP_SIZE).roll(1);
say("PARENT<=>MOTHER:["~$parent~"]<=>["~ @pop[$i]~"]");
my @cross_points =Bool.roll($DNA_SIZE);
say(@cross_points);
@cross_points[$_] ?? ($parent[$_]=@pop[$i][$_]) !! $parent[$_] for (0..@cross_points.elems-1);
say("CHILD:["~$parent~"]");
}
return $parent;
}
#变异（在DNA_SIZE中的每一位（0/1)基因根据变异率MUTATION_RATE突变为(1/0)）
sub mutate($child) {
for 0..^$DNA_SIZE ->$point {
if rand < $MUTATION_RATE {
($child[$point] == 0) ?? ($child[$point] = 1) !! 0;
}
}
return $child;
}
sub Pop{
my @pop;
@pop[$_]= roll($DNA_SIZE, ^2).Array for ^$POP_SIZE;
return @pop;
}
### 01INPUT：初始化种群DNA
my @pop=Pop();
#say(@pop);
for (1..$N_GENERATIONS) {
#二进制DNA转为十进制并输入函数，得出y值
my @F_values = F(translateDNA(@pop));
### 02PROCESS：遗传选择过程
#计算适应度得分，评价个体的优劣
my @fitness = get_fitness(@F_values);
my $midx=@fitness.first: * == max(@fitness), :k;
my $MF_pop=@pop[$midx];
say("Most fitted DNA: ["~$MF_pop~"]"~translateDNA(Array($MF_pop)));
#say(@fitness[$midx] ~"="~max(@fitness));
#模拟自然环境的优胜劣汰,输入种群与适应度得分，返回优势种群
my @pop_sel = select(@pop, @fitness);
my @pop_copy=@pop_sel;
for @pop_sel -> $parentis rw {
#在优势种群中找到母亲，并与父亲进行繁衍
my $child = crossover($parent, @pop_copy);
###03OUTPUT：产生更多优势个体
#变异
$child = mutate($child);
#小孩列表更换为父亲列表
$parent= $child;
say("Most fitted CHILD=>["~$parent~"]"~translateDNA(Array($parent)));
}
}
页:
[1]