gareal.pas

用Delphi编写的遗传算法程序

//******************************************************//
//                 遗传算法实数编码求解                 //
//                     作者：李有为                     //
//******************************************************//


unit gaReal;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Buttons,math;

const
  br:double=10.0;
  bl:double=0.0;

type
  Twei=array of double;

  individual=record
    chrom:double;  //实数染色体
    fitness:double; //适应值
  end;

  bestever=record
    chrom:double;
    fitness:double;
    generation:Integer;
  end;

type
  TgaRealFrm = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    Splitter1: TSplitter;
    Panel3: TPanel;
    Panel4: TPanel;
    GroupBox1: TGroupBox;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Edit5: TEdit;
    Edit6: TEdit;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Splitter2: TSplitter;
    Memo1: TMemo;
    Memo2: TMemo;
    procedure quickSort(var a:Twei;l,r:integer);//快速排序法
    procedure objFunc(var critter:individual);   //适应值计算函数
    procedure initData;
    procedure BitBtn1Click(Sender: TObject); //初始读入数据
    procedure statistics(pop:array of individual);
    procedure select;  //选择操作
    procedure cross;  //交叉运算
    procedure mutation;  //变异操作
    procedure run;   //遗传算法运行
    procedure repchar(ch:pchar;const repcount:integer);  //格式化输出
    procedure skip(const skipcount:integer); //输出空行
    procedure report;  //输出种群统计结果
    procedure BitBtn2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  gaRealFrm: TgaRealFrm;
  newpop: array of individual;   //当前代
  bestfit: bestever;     //最佳代
  sumfitness: double;    //适应值之和
  max, avg, min: double;   //最佳适应值，平均适应值，最小适应值
  pselection,pcross, pmutation: double;  //选择率，交叉率，变异率
  ncross,nmutation:Integer;  //交叉次数，变异次数
  popsize,gen,maxgen:Integer; //种群数，当前代数，最大代数
  randomseed:Double;   //初始化随机数种子
  oldrand:array[0..54] of double;
  jrand: integer;
  f:TextFile;

implementation

{$R *.dfm}

{ TgaRealFrm }

//*********************************************//
//                初始化数据                   //
//*********************************************//
procedure TgaRealFrm.initData;
var
  i:integer;
begin
  Randomize;
  try
    popsize := strtoint(trim(edit2.Text));
    maxgen := strtoint(trim(edit3.Text));
    pcross := strtofloat(trim(edit4.Text));
    pmutation := strtofloat(trim(edit5.Text));
    pselection := strtofloat(trim(edit6.Text));
  except
    showmessage('请输入正确数据!');
    exit;
  end;
  SetLength(newpop,popsize);
  for i := 0 to popsize-1 do
  begin
    newpop[i].chrom := random(100001)/10000;
    objFunc(newpop[i]);
  end;
  nmutation := 0;  //变异次数
  ncross := 0;  //交叉次数
  bestfit.chrom := 0;
  bestfit.fitness := 0;
  bestfit.generation := 0;
  statistics(newpop);
  repchar('-',80);
  skip(1);
  writeln(f,'初始代统计情况  ');
  Writeln(f,'个体  染色体       适应度');
  for i := 0 to popsize-1 do
    Writeln(f,i+1,')','     ',formatfloat('0.0000000',newpop[i].chrom),'    ',formatfloat('0.0000000',newpop[i].fitness));
  repchar('-',100);
  skip(1);
  writeln(f,'交叉操作次数 = ', ncross, ' 变异操作数 = ', nmutation);
  writeln(f,' 最小适应度：', formatfloat('0.0000000',min), ' 最大适应度：', formatfloat('0.0000000',max), format(' 平均适应度 %12.7f', [avg]));
  writeln(f,' 适应度：', formatfloat('0.0000000',bestfit.fitness));
  writeln(f,' 染色体: ');
  writeln(f,formatfloat('0.0000000',bestfit.chrom));
  writeln(f);
  skip(1);
  repchar('-', 80);
  skip(1);
end;

//*********************************************//
//                适应值函数                   //
//*********************************************//
procedure TgaRealFrm.objFunc(var critter: individual);
begin
  critter.fitness := 20+critter.chrom+10*sin(4*critter.chrom)+8*cos(3*critter.chrom);
end;

//*********************************************//
//                快速排序法                   //
//*********************************************//
procedure TgaRealFrm.quickSort(var a: Twei; l, r: integer);
var
  i,j:integer;
  temp,mid:double;
begin
  i:=l;j:=r; mid:=a[(l+r) div 2];   //将当前序列在中间位置的数定义为中间数
  repeat
    while a[i]< mid do inc(i);    //在左半部分寻找比中间数大的数
    while mid< a[j] do dec(j);   //在右半部分寻找比中间数小的数
    if i<=j then
    begin                        //若找到一组与排序目标不一致的数对则交换它们
      temp:=a[i];
      a[i]:=a[j];
      a[j]:=temp;
      inc(i);
      dec(j);               //继续找
    end;
  until i >j;
  if l< j then quickSort(a,l,j);     //若未到两个数的边界，则递归搜索左右区间
  if i< r then quickSort(a,i,r);
end;

procedure TgaRealFrm.BitBtn1Click(Sender: TObject);
var
  i:integer;
begin
  screen.Cursor := crHourGlass;
  AssignFile(f,'结果.txt');
  Rewrite(f);
  initData;
  run;
  CloseFile(f);
  memo1.ScrollBars:=ssBoth;
  memo1.Clear;
  memo1.Lines.LoadFromFile('结果.txt');
  screen.Cursor := crDefault;
end;

//*********************************************//
//                个体统计                     //
//*********************************************//
procedure TgaRealFrm.statistics(pop: array of individual);
var
  i,j:integer;
begin
  sumfitness := 0.0;
  min := pop[0].fitness;
  max := pop[0].fitness;
  for i := 0 to popsize-1 do
  begin
    sumfitness := sumfitness+pop[i].fitness;
    if pop[i].fitness>max then
      max := pop[i].fitness;
    if pop[i].fitness<min then
      min := pop[i].fitness;
    if pop[i].fitness>bestfit.fitness then
    begin
      bestfit.chrom := pop[i].chrom;
      bestfit.fitness := pop[i].fitness;
      bestfit.generation := gen;
    end;
  end;
  avg := sumfitness/popsize;
end;

//*********************************************//
//                选择算法                     //
//*********************************************//
procedure TgaRealFrm.select;
var
  i,j,k:Integer;
  fitIn,newIn:Integer;
  t:double; //分布值
  p,q,r:Twei; //染色体选择概率，i染色体的适应值在种群中按由大到小的序号，染色体的累积选择概率，随机升序数列
  n:array of integer;
begin
  SetLength(p,popsize);
  SetLength(n,popsize);
  SetLength(q,popsize);
  SetLength(r,popsize);
  t := pselection/(1-Power(1-pselection,popsize));
  try
    //k染色体的适应值在种群中按由大到小排列序号
    for i := 0 to popsize-1 do
    begin
      k := 1;
      q[i] := 0;
      for j := 0 to popsize-1 do
      begin
        if (i>j) and (newpop[i].fitness<=newpop[j].fitness) then
          k := k+1;
        if (i<j) and (newpop[i].fitness<newpop[j].fitness) then
          k := k+1;
      end;
      n[i] := k;
    end;

    //计算累积概率
    for i:=0 to popsize-1 do
    begin
      p[i] := t*Power(1-pselection,n[i]-1);
      if i=0 then
        q[i] := p[0]
      else
        q[i] := q[i-1]+p[i];
    end;

    //在[0,1]区间内产生按升序排列的随机数列r
    for i:=0 to popsize-1 do
      r[i] := random(1000001)/1000000;
    quickSort(r,0,popsize-1);

    //对染色体进行选择
    fitIn := 0;
    newIn := 0;
    while (newIn < popsize) do
    begin
      if r[newIn]<q[fitIn] then
      begin
        newpop[newIn].chrom := newpop[fitIn].chrom;
        newpop[newIn].fitness := newpop[fitIn].fitness;
        newIn := newIn+1;
      end
      else
        fitIn := fitIn+1;
    end;

   { memo2.Lines.Add('              中间结果显示：  第'+inttostr(gen)+'代');
    memo2.Lines.Add('适应值排列序号   染色体选择概率    累积选择概率   随即升序排列数');
    for i:=0 to popsize-1 do
    begin
      memo2.Lines.Add(inttostr(n[i])+'                       '+FormatFloat('0.00000',p[i])+'                      '+FormatFloat('0.00000',q[i])+'                               '+FormatFloat('0.00000',r[i]));
    end;}

  finally
    p := nil;
    n := nil;
    q := nil;
    r := nil;
  end;

end;

procedure TgaRealFrm.BitBtn2Click(Sender: TObject);
begin
  memo1.ScrollBars:=ssBoth;
  memo1.Clear;
  memo1.Lines.LoadFromFile('结果.txt');
end;

//*********************************************//
//                交叉算法                     //
//*********************************************//
procedure TgaRealFrm.cross;
var
  k:integer;
  m,n:integer;
  rl:double;
begin
  k := 0;
  ncross := trunc(pcross*popsize/2);
  if ncross<1 then
  begin
    showmessage('请调高相应交叉率!');
    edit4.SetFocus;
    exit;
  end;
  try
    repeat
      m := random(popsize);
      n := random(popsize);
      rl := random(100001)/100000;
      newpop[m].chrom := newpop[m].chrom*rl+newpop[n].chrom*(1-rl);
      newpop[n].chrom := newpop[m].chrom*(1-rl)+newpop[n].chrom*rl;
      objFunc(newpop[m]);
      objFunc(newpop[n]);
      k := k+1;
    until (k=ncross);
  except
    showmessage('参数输入错误，请重新设置！');
    exit;
  end;
end;

//*********************************************//
//                变异算法                     //
//*********************************************//
procedure TgaRealFrm.mutation;
var
  k,m:integer;
  t:double; //进化标记
  b:integer; //形状系数
  y,dv:double; //染色体的变异量
  rl:double; //[0,1]区间随机数
begin
  b := 3;
  t := gen/maxgen;
  k := 0;
  nmutation := trunc(pmutation*popsize);
  if nmutation<1 then
  begin
    showmessage('请调高相应变异率!');
    edit5.SetFocus;
    exit;
  end;
  try
    repeat
      //m := rnd(0,popsize-1);
      m := random(popsize);
      if random(2)=0 then
        y := br-newpop[m].chrom
      else
        y := newpop[m].chrom-bl;
      rl := random(100001)/100000;
      dv := y*Power(rl*(1-t),b);
      if random(2)=0 then
        newpop[m].chrom := newpop[m].chrom+dv
      else
        newpop[m].chrom := newpop[m].chrom-dv;
      objFunc(newpop[m]);
      k := k+1;
    until (k=nmutation);
  except
    showmessage('参数输入错误，请重新设置！');
    exit;
  end;
end;

//*********************************************//
//                遗传运行                     //
//*********************************************//
procedure TgaRealFrm.run;
begin
  gen := 0;
  while (gen<maxgen) do
  begin
    select;
    cross;
    mutation;
    statistics(newpop);
    report;
    gen := gen+1;
  end;
end;

procedure TgaRealFrm.repchar(ch: pchar; const repcount: integer);
var
  i:integer;
begin
  for i := 0 to repcount-1 do
    write(f,ch);
end;

//*********************************************//
//                结果输出                     //
//*********************************************//
procedure TgaRealFrm.report;
var
  i:integer;
begin
  repchar('-',80);
  skip(1);
  writeln(f,'模拟计算统计报告  ');
  Writeln(f,'世代数 ',gen+1);
  Writeln(f,'个体   染色体         适应度');
  for i := 0 to popsize-1 do
    Writeln(f,i+1,')','     ',formatfloat('0.0000000',newpop[i].chrom),'     ',formatfloat('0.0000000',newpop[i].fitness));
  repchar('-',100);
  skip(1);
  writeln(f,format('第 %d 代统计: ', [gen+1]));
  writeln(f,'交叉操作次数 = ', ncross, ' 变异操作数 = ', nmutation);
  writeln(f,' 最小适应度：', formatfloat('0.0000000',min), ' 最大适应度：', formatfloat('0.0000000',max), format(' 平均适应度 %12.7f', [avg]));
  writeln(f,format(' 迄今发现最佳个体 => 所在代数： %d ', [bestfit.generation+1]));
  writeln(f,' 适应度：', formatfloat('0.0000000',bestfit.fitness));
  writeln(f,' 染色体: ');
  writeln(f,formatfloat('0.0000000',bestfit.chrom));
  writeln(f);
  skip(1);
  repchar('-', 80);
  skip(1);
end;

procedure TgaRealFrm.skip(const skipcount: integer);
var
  i:integer;
begin
  for i := 0 to skipcount-1 do
    writeln(f);
end;

procedure TgaRealFrm.FormCreate(Sender: TObject);
begin
  memo2.Clear;
  memo2.ScrollBars:=ssBoth;
end;

end.