unit1.~pas

遗传算法(Genetic Algorithm, GA)是近几年发展起来的一种崭新的全局优化算法

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CheckLst, Grids, ValEdit, Buttons, ExtCtrls;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    GroupBox6: TGroupBox;
    Label4: TLabel;
    Label3: TLabel;
    Label2: TLabel;
    Label1: TLabel;
    Editevolve: TEdit;
    EditPc: TEdit;
    Editaberrance: TEdit;
    Editcount: TEdit;
    Panel10: TPanel;
    GroupBox1: TGroupBox;
    RadioMax: TRadioButton;
    Radiomin: TRadioButton;
    GroupBox2: TGroupBox;
    Radioexpect: TRadioButton;
    Radioroulette: TRadioButton;
    GroupBox3: TGroupBox;
    Radiosingle: TRadioButton;
    Radiodouble: TRadioButton;
    Radioequality: TRadioButton;
    Panel6: TPanel;
    Panel7: TPanel;
    BitBtn2: TBitBtn;
    Panel11: TPanel;
    Label5: TLabel;
    BitBtn1: TBitBtn;
    Editstate: TEdit;
    Panel2: TPanel;
    Panel5: TPanel;
    Panel4: TPanel;
    Button3: TButton;
    Button1: TButton;
    Button2: TButton;
    Panel3: TPanel;
    StringGrid1: TStringGrid;
    Panel8: TPanel;
    clb: TCheckListBox;
    Panel9: TPanel;
    Panel12: TPanel;
    GroupBox4: TGroupBox;
    Memo2: TMemo;
    GroupBox5: TGroupBox;
    Label6: TLabel;
    Memo1: TMemo;
    Label11: TLabel;
    Edit1: TEdit;
    Label7: TLabel;
    Edit2: TEdit;
    Label9: TLabel;
    StringGrid3: TStringGrid;
    Label10: TLabel;
    StringGrid2: TStringGrid;
    StringGrid4: TStringGrid;
    Label8: TLabel;
    E_10: TEdit;
    Edit3: TEdit;
    StringGrid5: TStringGrid;
    procedure gy;
    procedure DT_init;
    procedure UI_init;
    procedure FormShow(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
   // procedure Button3Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);//变异
   // procedure BitBtn2Click(Sender: TObject);
    procedure maxPro;//求最大值时的适应值
    procedure minPro;//求最小值时的适应值
    procedure expPro;//期望值法
    procedure roulettePro;//轮盘赌法    这里还有问题
    procedure intersectPro;//交叉
    procedure aberrancePro;
    procedure showDT(n:integer;memo1:Tmemo);
    procedure showDT1(n:integer;memo1:Tmemo);
    procedure gya;
  private
    { Private declarations }
  public
    { Public declarations }
  end;
CONST INMAX=500;
CONST OUTMAX=500;
type TSmpIns =array[1..INMAX] of real;
type TSmpOuts=array[1..OUTMAX] of real;

function trun(const number:real;const l:integer):TSmpouts;
function retrun(const a:Tsmpouts;const l:integer):real;

var
  Form1: TForm1;

implementation
uses Unit_gene;
 var  interval:array of array of real; //各个个体的每个隶属度的取值范围
      smp:array of array of array of real;   //smp记录系统随机产生的种群样本
     smp_gene:array of array of real;  //smp_gene记录经区间划分后相应隶属度的对应数值
      outs:array of real;      //outs记录适应度函数的输出值
      fit:array of real;     //fit记录适应值
      smp_c:array of real;     //smp_c为种群的复制数
       ybmm:array of array of real;
       qzmm:array of real;
       qz:array of array of real;//权值A
       o:array of integer;//等级
       resulte:array of array of array of real;
       result1:integer;
       u:array of array of integer;//等级数据
 var  gcount,count,Gn,grade:integer;      //gcount为等级数,count为个体数,Gn为进化代数,grade为隶属度
      sumf,min,max:real;
      //q,r,k,t:integer;
      input:TSmpins;
      a1,a2,output:TSmpouts;
      Pc,Pm,temp:real;//pc为交叉概率，Pm为变异概率
      c,d,c2,d2:integer;
      ymm:real;//记录最大输出值
      ys:integer;
      data:integer;
{$R *.dfm}
procedure tform1.gy;
var i,j,k:integer;
    sumf:real;
begin
    for k:=0 to count-1 do
     for i:=0 to gcount-1 do
     begin
      sumf:=0;
      for j:=0 to grade-1 do
       sumf:=sumf+smp[k][i][j];
       for j:=0 to grade-1 do
       smp[k][i][j]:=smp[k][i][j]/sumf;
     end;
end;

procedure tform1.gya;
var i,j:integer;
    sumf:real;
begin
 for i:=0 to count-1 do
  begin
  sumf:=0;
  for j:=0 to ys-1 do
   sumf:=sumf+qz[i][j];
   for j:=0 to ys-1 do
   qz[i][j]:=qz[i][j]/sumf;
  end;
end;

procedure Tform1.UI_init;
var i:integer;
begin
  StringGrid1.ColCount:=strtoint(editstate.text)+1;
  stringgrid2.ColCount:=strtoint(edit2.Text);
  StringGrid1.Cells[0,0]:='隶属度';
  //StringGrid1.Cells[1,0]:='取值下限';
  //for i:=2 to strtoint(editstate.text) do
    //StringGrid1.Cells[i,0]:='隶属度 '+inttostr(i-1)+' 上限';
  StringGrid1.ColWidths[0]:=50;
  StringGrid1.RowCount:=1;
  clb.Items.Clear;
  for i:=1 to gcount do
  begin
    clb.Items.Add('--->');
    if (StringGrid1.RowCount<>2) or (StringGrid1.Cells[0,1]<>'') then
    StringGrid1.RowCount:=StringGrid1.RowCount+1;
    StringGrid1.Cells[0,StringGrid1.RowCount-1]:=
       //       form1.Grid1.Cells[StringGrid1.RowCount-1,0];
        '等级'+inttostr(StringGrid1.RowCount-1);
  end;
  //panel5.Width:=trunc((5+1)*stringGrid1.ColWidths[1]);
end;

//等级取值范围初始化
procedure Tform1.DT_init;
var i,j:integer;
begin
  //setlength(interval,gcount,5);//'5'是基因取值的区间数加 1
  setlength(interval,gcount,strtoint(editstate.text));
  for i:=0 to gcount-1 do   //初始化bx,ax,gx
    for j:=0 to strtoint(editstate.text)-1 do
    //for j:=0 to 4 do
      interval[i][j]:=strtofloat(StringGrid1.cells[j+1,i+1]);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
StringGrid1.RowCount:=1;
  gcount:=strtoint(edit1.Text);
  bitbtn1.Click;
  UI_init;
  setlength(interval,gcount,StringGrid1.ColCount-1);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
    i,j,t,k,g,http,temo:integer;
    Gn2:integer;
    chkM,Gn1:real; flag:integer;
    temp:array of real;
    temp1:array of integer;
    sump:integer;
begin
edit3.Text:='';
//for i:=0 to strtoint(e_10.text)-1 do
//stringgrid5.cells[0,i]:='';
try
  grade:=strtoint(editstate.text);
  ys:=strtoint(edit2.Text);
  data:=strtoint(e_10.Text);
  try
    Pc:=strtofloat(editpc.Text);
    Pm:=strtofloat(Editaberrance.Text);
    Gn:=strtoint(Editevolve.Text);

  except
    showmessage('相关参数不全，请输入');
    Editevolve.SetFocus;
    exit;
  end;
  try
    count:=strtoint(editcount.Text);
  except
    randomize;
    count:=random(15)+gcount;     //如果用户不确定个体数目，系统将自动生成
    editcount.Text:=inttostr(count);
  end;
  setlength(o,data);
  setlength(u,data,ys);
  setlength(qz,count,ys);
  setlength(smp,count,gcount,grade);
  setlength(smp_gene,ys,grade);
  setlength(fit,count);
  setlength(ybmm,grade,gcount);
  setlength(qzmm,ys);
  setlength(smp_c,count);
  setlength(outs,count);
  setlength(temp,grade);
  setlength(temp1,data);
  setlength(resulte,count,data,grade);
 // setlength(result1,grade);
  DT_init;
  //button1.Click;
  for i:=0 to ys-1 do
  qz[0][i]:=strtofloat(stringgrid2.Cells[i,0]);
  for i:=0 to data-1 do
   for j:=0 to ys-1 do
    u[i][j]:=strtoint(stringgrid3.Cells[j,i]);
  for i:=0 to data-1 do
   o[i]:=strtoint(stringgrid4.Cells[0,i]);

   for t:=0 to ys-1 do
     for j:=0 to grade-1 do
      begin
       smp_gene[t][j]:=0;
       temp[j]:=0;
      end;
    max:=0;    //初始0
    sump:=0;
for g:=0 to data-1 do
  begin
   max:=0;
   for t:=0 to ys-1 do
     for j:=0 to grade-1 do
      begin
       smp_gene[t][j]:=0;
       temp[j]:=0;
      end;
   for t:=0 to ys-1 do
    for j:=0 to grade-1 do
      for i:=0 to gcount-1 do
       smp_gene[t][j]:=smp_gene[t][j]+interval[u[g][t]-1][i]*interval[i][j];
   for i:=0 to grade-1 do
    begin
      for j:=0 to ys-1 do
       temp[i]:=temp[i]+qz[0][j]*smp_gene[j][i];
       //resulte[k][g][i]:=temp[i];
      if temp[i]>max then
       begin
        max:=temp[i];
        //temo:=i+1;
       temp1[g]:=i+1;
       end;
     end;
     stringgrid5.Cells[0,g]:=inttostr(temp1[g]);
    if temp1[g]=o[g] then sump:=sump+1;
    edit3.Text:=inttostr(sump);
   end;

   //系统随机生成种群，每个个体包含5个基因，共n个个体
  randomize;

  for k:=0 to count-1 do
  begin
   for i:=0 to ys-1 do
   if (qz[0][i]-0.05>0)and(k>0) then
    qz[k][i]:=qz[0][i]-random*0.05;
      if (qz[0][i]-0.05>0) then
     qz[0][i]:=qz[0][i]-random*0.05;
  for i:=0 to gcount-1 do
   begin
      for j:=0 to grade-1 do
      // smp[i][j][k]:=random*(interval[j][grade]-interval[j][0])+interval[j][0];
       if interval[i][j]<>0 then
       smp[k][i][j]:=interval[i][j]-random*0.05 ;
  end;
  end;
 gy;
 gya;
// 根据v,g,a,b区间的数值范围重定义种群基因
 { for i:=0 to count-1 do
  begin
    for j:=0 to gcount-1 do
    begin //if j<=4then //第1～4个基因越大越好
      if clb.Checked[j]=false then
        begin
          for t:=0 to grade-1 do
            if smp[i][j]>interval[j][t] then
            smp_gene[i][j]:=strtofloat(vle.Values[vle.Keys[t+1]]);
          {if smp[i][j]<=interval[j][1] then smp_gene[i][j]:=-1.5
          else  if smp[i][j]<=interval[j][2] then smp_gene[i][j]:=-0.5
                else  if smp[i][j]<=interval[j][3] then smp_gene[i][j]:=0.5
                      else smp_gene[i][j]:=1.5;}
 {       end //第5个基因越小越好
      else
        begin
          for t:=0 to grade-1 do
            if smp[i][j]<interval[j][t] then
            smp_gene[i][j]:=strtofloat(vle.Values[vle.Keys[t+1]]);
          {if smp[i][j]>interval[j][1] then smp_gene[i][j]:=-1.5
          else if smp[i][j]>interval[j][2] then smp_gene[i][j]:=-0.5
               else if smp[i][j]>interval[j][3] then smp_gene[i][j]:=0.5
                    else smp_gene[i][j]:=1.5;}
  {      end;
    end;
  end;}

//调用BP模型，计算smp_gene[n][5]的输出，获得输出outs[n]
//把结果存入数组fit[n]
Gn1:=0; Gn2:=1;     flag:=0;
if radiomax.Checked then ymm:=0;
if radiomin.Checked then ymm:=1;
http:=0; temo:=0;
while Gn2<Gn do
begin
 { for i:=1 to count do
  begin
    for j:=1 to gcount do
    input[j]:=smp_gene[i-1][j-1];
    output:=model.Calculate(input);
    outs[i-1]:=output[1];  //这里有问题，如果输出不是一个点怎么办？
    fit[i-1]:=outs[i-1];
  end; }
  for k:=0 to count-1 do
  begin
    for t:=0 to ys-1 do
     for j:=0 to grade-1 do
      begin
       smp_gene[t][j]:=0;
       temp[j]:=0;
      end;
    max:=0;    //初始0
   // h:=trunc(random*data);
    sump:=0;
   for g:=0 to data-1 do
   begin
     for t:=0 to ys-1 do
     for j:=0 to grade-1 do
      begin
       smp_gene[t][j]:=0;
       temp[j]:=0;
      end;
     max:=0;
   for t:=0 to ys-1 do
    for j:=0 to grade-1 do
      for i:=0 to gcount-1 do
       smp_gene[t][j]:=smp_gene[t][j]+smp[k][u[g][t]-1][i]*smp[k][i][j];
    for i:=0 to grade-1 do
     begin
      for j:=0 to ys-1 do
       temp[i]:=temp[i]+qz[k][j]*smp_gene[j][i];
       resulte[k][g][i]:=temp[i];
      if temp[i]>max then
       begin
        max:=temp[i];
        //temo:=i+1;
       temp1[g]:=i+1;
      // if temp1[g]=o[g] then sump:=sump+1;
       end;

     end;
      if temp1[g]=o[g] then sump:=sump+1;
      outs[k]:=sump;fit[k]:=sump;
     //if fit[k]<>o then outs[k]:=0;
     //fit[k]:=outs[k];
    end;
   end;
  chkM:=outs[0]; http:=0;
 if radiomax.Checked then
   begin
    for k:=1 to count-1 do
     if outs[k]>chkM then
      begin
      http:=k;  chkM:=outs[k];
      end;
    if chkm>ymm then
       begin
        ymm:=chkm;
        for i:=0 to ys-1 do
        qzmm[i]:=qz[http][i];
        for i:=0 to gcount-1 do
        begin
       // result1[i]:=result[http][i];
        for j:=0 to grade-1 do
         ybmm[i][j]:=smp[http][i][j];
        end;
       end;
   end;

  if radiomin.Checked then
  begin
   for i:=1 to count-1 do
     if outs[i]<chkM then
      begin
      http:=i;  chkM:=outs[i];
      end;
    if chkm<ymm then
      begin
      ymm:=chkm;
      for i:=0 to ys-1 do
        qzmm[i]:=qz[http][i];
        for i:=0 to gcount-1 do
        for j:=0 to grade-1 do
         ybmm[i][j]:=smp[i][j][http];
      end;
    end;

  if Gn2=1 then
  begin
    //showDT(Gn2,form_gene.Memo2);
    showDT1(Gn2,Memo2);
  end;

   if abs(ymm-Gn1)<0.00000000000000001 then    //‘0.0001’是误差值，应该要用户设定，这里还没有做这一步
    begin
    if flag=50 then
      begin
      //showDT(Gn2,form_gene.Memo1);
      showDT1(Gn2,Memo1);
      //form_gene.ShowModal;
      //showmessage(inttostr(Gn2));
      break;
    end ;
    end
  else
    begin
      smp[0][1][1]:=smp[0][1][1];
      if radiomax.Checked then maxPro;
      if radiomin.Checked then minPro;
      if radioexpect.Checked then expPro;
      if radioroulette.Checked then roulettePro;
      intersectPro;
      aberrancePro;
    end;
  flag:=flag+1;
  if flag=51 then
  begin Gn1:=ymm;  flag:=0;end;
  Gn2:=Gn2+1;
end;
if Gn2=Gn then
  begin
    //showDT(Gn2,form_gene.Memo1);
    showDT1(Gn2,Memo1);
  //form_gene.ShowModal;
  end;
except
  showmessage('出错');
end;
end;



procedure Tform1.maxPro;//求最大值时的适应值
var i:integer;
begin
  min:=fit[0];
  max:=fit[0];
  for i:=1 to count-1 do
  begin   //找出BP模型的输出结果中的最小值和最大值
    if fit[i]<min then min:=fit[i];
    if fit[i]>max then max:=fit[i];
  end;
  for i:=0 to count do
  begin
    if min>=0 then  //若每一个输出结果都大于零，则就为其的适应值
      fit[i]:=fit[i]