gadelphi.~pas

一个用于基本遗传算法计算得源程序。用dephi编写的。

      oldpop[j].parent[1] := 0;
      oldpop[j].xsite := 0;
      objfunc(oldpop[j]);
    end;
  end;
end;

procedure TGA.objfunc(var critter: individual); //* 计算适应度函数值 */
var
  mask, bitpos, tp: cardinal;
  bitpow: double;
  j, k, stop: integer;
begin
  mask := 1;
  critter.varible := 0.0;
  for k := 0 to chromsize - 1 do
  begin
    if (k = (chromsize - 1)) then
      stop := lchrom - (k * (8 * sizeof(cardinal)))
    else
      stop := 8 * sizeof(cardinal);
    tp := critter.chrom[k];
    for j := 0 to stop - 1 do
    begin
      bitpos := j + (8 * sizeof(cardinal)) * k;
      if ((tp and mask) = 1) then
      begin
        bitpow := power(2.0, bitpos);
        critter.varible := critter.varible + bitpow;
      end;
      tp := tp shr 1;
    end;
  end;
  critter.varible := -1 + critter.varible * 3 / (power(2.0, lchrom) -
    1);
  critter.fitness := critter.varible * sin(critter.varible * 10 * arctan(1)
    * 4) + 2.0;
end;


function TGA.flip(prob: single): boolean; // 以一定概率产生0或1
begin
  if (randomperc <= prob) then
    result := true
  else
    result := false;
end;

function TGA.select: integer; //* 轮盘赌选择*/
var
  sum, pick: single;
  i: integer;
begin
  pick := randomperc;
  sum := 0;
  i := 0;
  if (sumfitness <> 0) then
    while ((sum < pick) and (i < popsize)) do
    begin
      sum := sum + oldpop[i].fitness / sumfitness;
      inc(i);
    end
  else
    i := rnd(1, popsize);
  result := i - 1;
end;

function TGA.rnd(low, high: integer): integer;
  //*在整数low和high之间产生一个随机整数*/
var
  i: integer;
begin
  if (low >= high) then
    i := low
  else
  begin
    i := trunc((randomperc * (high - low + 1)) + low);
    if (i > high) then
      i := high;
  end;
  result := i;
end;

function TGA.crossover(var parent1, parent2, child1, child2: PUnsigned): integer;
  // * 由两个父个体交叉产生两个子个体 * /
var
  j, jcross, k: integer;
  mask, temp: cardinal;
begin
  if (flip(pcross)) then
  begin
    jcross := rnd(1, (lchrom - 1)); // * Cross between 1 and l - 1 * /
    inc(ncross, 1);
    for k := 1 to chromsize do
    begin
      if (jcross >= (k * (8 * sizeof(cardinal)))) then
      begin
        child1[k - 1] := parent1[k - 1];
        child2[k - 1] := parent2[k - 1];
      end
      else
        if ((jcross < (k * (8 * sizeof(cardinal)))) and (jcross > ((k - 1) * (8 *
          sizeof(cardinal))))) then
        begin
          mask := 1;
          for j := 1 to jcross - 1 - ((k - 1) * (8 * sizeof(cardinal))) do
          begin
            temp := 1;
            mask := mask shr 1;
            mask := mask and temp;
          end;
          child1[k - 1] := (parent1[k - 1] and mask) or (parent2[k - 1] and (not
            mask));
          child2[k - 1] := (parent1[k - 1] and (not mask)) or (parent2[k - 1] and
            mask);
        end
        else
        begin
          child1[k - 1] := parent2[k - 1];
          child2[k - 1] := parent1[k - 1];
        end;
    end;
  end
  else
  begin
    for k := 0 to chromsize - 1 do
    begin
      child1[k] := parent1[k];
      child2[k] := parent2[k];
    end;
    jcross := 0;
  end;
  result := jcross;
end;

procedure TGA.mutation(child: PUnsigned); //*变异操作*/
var
  j, k, stop: integer;
  mask, temp: cardinal;
begin
  temp := 1;
  for k := 0 to chromsize - 1 do
  begin
    mask := 0;
    if (k = (chromsize - 1)) then
      stop := lchrom - (k * (8 * sizeof(cardinal)))
    else
      stop := 8 * sizeof(cardinal);
    for j := 0 to stop - 1 do
    begin
      if (flip(pmutation)) then
      begin
        mask := mask or (temp shl j);
        inc(nmutation, 1);
      end;
    end;
    child[k] := child[k] xor mask;
  end;
end;

procedure TGA.generation;
var
  mate1, mate2, jcross, j: integer;
begin
  j := 0;
  //*  每代运算前进行预选 */
  preselect;
  //* 选择, 交叉, 变异 */
  repeat
      //* 挑选交叉配对 */
    mate1 := select();
    mate2 := select();
      //* 交叉和变异 */
    jcross := crossover(oldpop[mate1].chrom, oldpop[mate2].chrom, newpop[j].chrom,
      newpop[j + 1].chrom);
    mutation(newpop[j].chrom);
    mutation(newpop[j + 1].chrom);
      //* 解码, 计算适应度 */
    objfunc(newpop[j]);
      //*记录亲子关系和交叉位置 */
    newpop[j].parent[0] := mate1 + 1;
    newpop[j].xsite := jcross;
    newpop[j].parent[1] := mate2 + 1;
    objfunc(newpop[j + 1]);
    newpop[j + 1].parent[0] := mate1 + 1;
    newpop[j + 1].xsite := jcross;
    newpop[j + 1].parent[1] := mate2 + 1;
    j := j + 2;
  until (j >= (popsize - 1));
end;

procedure TGA.preselect;
var
  j: integer;
begin
  sumfitness := 0;
  for j := 0 to popsize - 1 do
    sumfitness := sumfitness + oldpop[j].fitness;
end;

procedure TGA.Go;
begin
  gen := 0;
  while (gen < maxgen) do
  begin
      //fprintf(outfp, "\n第 %d / %d 次运行: 当前代为 %d, 共 %d 代\n", run, maxruns,
        //gen, maxgen);
      // * 产生新一代 * /
    generation;
      // * 计算新一代种群的适应度统计数据 * /
    statistics(newpop);
      // * 输出新一代统计数据 * /
    report;

    temp := copy(oldpop);
    oldpop := copy(newpop);
    newpop := copy(temp);
    inc(gen, 1);
  end;
//  freeall();
end;

procedure TGA.repchar(ch: pchar; repcount: integer);
var
  j: integer;
begin
  for j := 1 to repcount - 1 do
    write(ch);
end;

procedure TGA.report; //* 输出种群统计结果 */

begin
  repchar('-', 80);
  skip(1);
  if (printstrings = 1) then
  begin
    repchar(' ', ((80 - 17) div 2));
    writeln('模拟计算统计报告  ');
    write('世代数 ', gen);
    repchar(' ', (80 - 28));
    writeln('世代数 ', (gen + 1));
    write('个体  染色体编码');
    repchar(' ', lchrom - 5);
    write('适应度    父个体 交叉位置  ');
    write('染色体编码 ');
    repchar(' ', lchrom - 5);
    write('适应度');
    repchar('-', 80);
    skip(1);
    writepop();
    repchar('-', 80);
    skip(1);
  end;
  writeln('第 %d 代统计: ', gen);
  writeln('总交叉操作次数 = ', ncross, ' 总变异操作数 = ', nmutation);
  writeln(' 最小适应度：', min, ' 最大适应度：', max, '  平均适应度 %f', avg);
  writeln(' 迄今发现最佳个体 =>  所在代数： %d  ', bestfit.generation);
  writeln(' 适应度：  染色体：', bestfit.fitness);
  writechrom(bestfit.chrom);
  writeln(' 对应的变量值: ', bestfit.varible);
  skip(1);
  repchar('-', 80);
  skip(1);
end;

procedure TGA.writepop;
var
  pind: individual;
  j: integer;
begin
  for j := 0 to popsize - 1 do
  begin
    write(j + 1, ' ');
        //* 当前代个体 */
    pind := oldpop[j];
    writechrom(pind.chrom);
    write(format('  %8f | ', [pind.fitness]));
        //* 新一代个体 */
    pind := newpop[j];
    write(format('(%2d,%2d)   %2d   ', [pind.parent[0], pind.parent[1],
      pind.xsite]));
    writechrom(pind.chrom);
    writeln(format('  %8f  ', [pind.fitness]));
  end;
end;

procedure TGA.writechrom(chrom: PUnsigned); //* 输出染色体编码 */
var
  j, k, stop: integer;
  mask, tmp: Cardinal;
begin
  mask := 1;
  for k := 0 to chromsize - 1 do
  begin
    tmp := chrom[k];
    if (k = (chromsize - 1)) then
      stop := lchrom - (k * (8 * sizeof(cardinal)))
    else
      stop := 8 * sizeof(cardinal);
    for j := 0 to stop - 1 do
    begin
      if (tmp and mask) = 1 then
        write('1')
      else
        write('0');
      tmp := tmp shr 1;
    end;
  end;
end;

end.