免费注册 查看新帖 |

Chinaunix

  平台 论坛 博客 文库
最近访问板块 发新帖
查看: 3897 | 回复: 0

求精简和修改perl6写的遗传算法GA [复制链接]

论坛徽章:
0
发表于 2020-01-04 18:46 |显示全部楼层
本帖最后由 aef25u 于 2020-01-06 19:21 编辑

仿照python用perl6实现了最简单的遗传算法,但感觉臃肿,请大牛帮精简或改写地更perler一些,只改部分代码均行。
其中:1、dot函数自已实现的只适用简单情况,不知perl6有没有现成的或哪个模块能提供?
        2、np.random.choice(python版函数),我用自己想的方法进行模拟(位于select()函数内),求改写地更简洁或更好的版本
  1.     my @p=@fitness.map: {$_/sum(@fitness)};
  2.     my %h=(0..@p.elems-1).map: {$_=>($POP_SIZE* @p[$_]*10).round(1)+1};
  3.     my @sample;
  4.     for %h.kv -> $key, $value {
  5.         #say("$key=>$value");
  6.         push(@sample,$key) for (1..$value);      
  7.     }
  8.     my @samshuffle=@sample.sort: { rand };
  9.     my @idx = @samshuffle.roll($POP_SIZE);
复制代码



  1. my $DNA_SIZE = 10;            # DNA 长度
  2. my $POP_SIZE = 100;           # 种群总数
  3. my $CROSS_RATE = 0.8;        # 交叉配对比率 (DNA crossover)
  4. my $MUTATION_RATE = 0.003;    # 变异率 mutation probability
  5. my $N_GENERATIONS = 200;      # 繁殖代数
  6. my @X_BOUND = (0, 5);         # x坐标范围

  7. sub dot(@a,@b) {
  8.     fail "Vector @a length not equal to @b!" unless +@a == +@b;
  9.     my @c = @a <<*>> @b;
  10. }

  11. # 查找某函数在X_BOUND范围内的最大值
  12. sub F(@x) {return @x.map:{sin(10*$_)*$_ + cos(2*$_)*$_}}

  13. #适应度函数(y值占所有y值合计的占比越大越有优势)
  14. #如果函数会产生负值,将横坐标轴下移,令所有y值均大于0,
  15. #因遗传选择时select(),@p=@fitness.map: {$_/sum(@fitness)};不能为负值且分母不能为0
  16. sub get_fitness(@pred) { return @pred.map: {$_ + 1e-3 - min(@pred)}}

  17. # DNA翻译规则:即x,二进制表示的DNA转为十进制,并将其归一化至(0, 5)
  18. sub translateDNA(@pop){return @pop.map: { [+](dot($_,(0..^$DNA_SIZE).reverse.map: { 2** $_} )) / (2**$DNA_SIZE-1)*@X_BOUND[1]}}

  19. #遗传选择函数,适者生存,不适者淘汰
  20. #按编号返回优势者个体列表;$p参数:表示选择标准(此例中按照比例来选择,适应度得分高的p有越大的概率被留下来)
  21. sub select(@pop, @fitness){
  22.     my @p=@fitness.map: {$_/sum(@fitness)};
  23.     my %h=(0..@p.elems-1).map: {$_=>($POP_SIZE* @p[$_]*10).round(1)+1};
  24.     my @sample;
  25.     for %h.kv -> $key, $value {
  26.         #say("$key=>$value");
  27.         push(@sample,$key) for (1..$value);      
  28.     }
  29.     my @samshuffle=@sample.sort: { rand };
  30.     my @idx = @samshuffle.roll($POP_SIZE);
  31.     return @pop[@idx];
  32. }

  33. #繁衍,优势个体作为父亲,按交叉配对比率CROSS_RATE在优势种群中选择母亲,生成小孩
  34. sub crossover($parent, @pop) {
  35.     if (rand <  $CROSS_RATE) {
  36.         my $i=(0..^$POP_SIZE).roll(1);
  37.         say("PARENT<=>MOTHER:["~$parent~"]<=>["~ @pop[$i]~"]");
  38.         my @cross_points =Bool.roll($DNA_SIZE);
  39.         say(@cross_points);
  40.         @cross_points[$_] ?? ($parent[$_]=@pop[$i][$_]) !! $parent[$_] for (0..@cross_points.elems-1);
  41.         say("CHILD:["~$parent~"]");
  42.         }
  43.         return $parent;
  44. }


  45. #变异(在DNA_SIZE中的每一位(0/1)基因根据变异率MUTATION_RATE突变为(1/0))
  46. sub mutate($child) {
  47.      for 0..^$DNA_SIZE ->$point {
  48.           if rand < $MUTATION_RATE {
  49.                  ($child[$point] == 0) ?? ($child[$point] = 1) !! 0;
  50.           }
  51.     }
  52.     return $child;
  53. }

  54. sub Pop{
  55.      my @pop;
  56.      @pop[$_]= roll($DNA_SIZE, ^2).Array for ^$POP_SIZE;
  57.      return @pop;
  58. }

  59. ### 01INPUT:初始化种群DNA
  60. my @pop=Pop();
  61. #say(@pop);

  62. for (1..$N_GENERATIONS) {
  63.     #二进制DNA转为十进制并输入函数,得出y值
  64.     my @F_values = F(translateDNA(@pop));
  65.    
  66.     ### 02PROCESS:遗传选择过程
  67.     #计算适应度得分,评价个体的优劣
  68.     my @fitness = get_fitness(@F_values);

  69.     my $midx=@fitness.first: * == max(@fitness), :k;
  70.     my $MF_pop=@pop[$midx];
  71.     say("Most fitted DNA: ["~$MF_pop~"]"~translateDNA(Array($MF_pop)));
  72.     #say(@fitness[$midx] ~"="~max(@fitness));

  73.     #模拟自然环境的优胜劣汰,输入种群与适应度得分,返回优势种群
  74.     my @pop_sel = select(@pop, @fitness);
  75.     my @pop_copy=@pop_sel;
  76.     for @pop_sel -> $parent  is rw {
  77.          #在优势种群中找到母亲,并与父亲进行繁衍
  78.          my $child = crossover($parent, @pop_copy);
  79.          ###03OUTPUT:产生更多优势个体
  80.          #变异
  81.          $child = mutate($child);
  82.          #小孩列表更换为父亲列表
  83.          $parent= $child;
  84.          say("Most fitted CHILD=>["~$parent~"]"~translateDNA(Array($parent)));
  85.     }
  86. }
复制代码




您需要登录后才可以回帖 登录 | 注册

本版积分规则 发表回复

DTCC2020中国数据库技术大会 限时8.5折

【架构革新 高效可控】2020年8月17日~19日第十一届中国数据库技术大会将在北京隆重召开。

大会设置2大主会场,20+技术专场,将邀请超百位行业专家,重点围绕数据架构、AI与大数据、传统企业数据库实践和国产开源数据库等内容展开分享和探讨,为广大数据领域从业人士提供一场年度盛会和交流平台。

http://dtcc.it168.com


大会官网>>
  

北京盛拓优讯信息技术有限公司. 版权所有 16024965号-6 北京市公安局海淀分局网监中心备案编号:11010802020122
中国互联网协会会员  联系我们:huangweiwei@it168.com
感谢所有关心和支持过ChinaUnix的朋友们 转载本站内容请注明原作者名及出处

清除 Cookies - ChinaUnix - Archiver - WAP - TOP