gadelphi.pas

只要输入相关参数就可以得到结果

      else
        stop := 8 * sizeof(cardinal);
      for j1 := 1 to stop do
      begin
        oldpop[j].chrom[k] := oldpop[j].chrom[k] shl 1;
        if flip(0.5) then
          oldpop[j].chrom[k] := oldpop[j].chrom[k] or mask;
      end;
      oldpop[j].parent[0] := 0;
      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;
  CloseFile(f);
  // freeall();
end;

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

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

begin
  repchar('-', 80);
  skip(1);
  if (printstrings = 1) then
  begin
    repchar(' ', ((80 - 17) div 2));
    writeln(f,'模拟计算统计报告 ');
    write(f,'世代数 ', gen);
    repchar(' ', (80 - 20));
    writeln(f,'世代数 ', (gen + 1));
    write(f,'个体     染色体编码');
    repchar(' ', lchrom - 5);
    write(f,'  适应度  父个体 交叉位置 ');
    write(f,'染色体编码 ');
    repchar(' ', lchrom - 5);
    write(f,'适应度');
    repchar('-', 80);
    skip(1);
    writepop();
    repchar('-', 80);
    skip(1);
  end;
  writeln(f,format('第 %d 代统计: ', [gen]));
  writeln(f,'总交叉操作次数 = ', ncross, ' 总变异操作数 = ', nmutation);
  writeln(f,' 最小适应度：', min, ' 最大适应度：', max, format(' 平均适应度 %f', [avg]));
  writeln(f,format(' 迄今发现最佳个体 => 所在代数： %d ', [bestfit.generation]));
  writeln(f,' 适应度：', bestfit.fitness);
  writeln(f,' 染色体: ');
  writechrom(bestfit.chrom);
  writeln(f);
  writeln(f,' 对应的变量值: ', 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(f,format('%3d) ',[j + 1]));
    //* 当前代个体 */
    pind := oldpop[j];
    writechrom(pind.chrom);
    write(f,format(' %8f |   ', [pind.fitness]));
    //* 新一代个体 */
    pind := newpop[j];
    write(f,format('(%2d,%2d)         %2d     ', [pind.parent[0], pind.parent[1],pind.xsite]));
    writechrom(pind.chrom);
    writeln(f,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(f,'1')
      else
        write(f,'0');
      tmp := tmp shr 1;
    end;
  end;
end;

end.