unit1.pas

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

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]
    else  fit[i]:=max-fit[i];
  end;
end;


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


procedure Tform1.expPro;//期望值法
var i,j,t,k:integer;
    che:real;
begin
//选择概率复制个体，淘汰劣个体
 sumf:=0;
 che:=0;
 for i:=0 to count-1 do
   begin sumf:=fit[i]+sumf; end;
 //若用户选择使用期望值方法
  for i:=0 to count-1 do    //计算相应的复制数
    begin
      smp_c[i]:=count*fit[i]/sumf;
      if ( smp_c[i]-trunc(smp_c[i]) )>0.5
        then smp_c[i]:=trunc(smp_c[i])+1
      else    smp_c[i]:=trunc(smp_c[i]);
        che:=smp_c[i]+che;
    end;


//if che>=15 then
    //begin    showmessage('复制数出错') ;  end;

   for i:=0 to count-1 do
     begin
       if smp_c[i]=0 then
       begin
         for j:=0 to count-1 do  if smp_c[j]>1 then  break;
         if j<count then
         begin
         for t:=0 to gcount-1 do
          for k:=0 to grade-1 do
         smp[i][t][k]:=smp[j][t][k];
         for t:=0 to ys-1 do
          qz[i][t]:=qz[j][t];
         smp_c[j]:=smp_c[j]-1;
         end;
       end;
      end;




    {for i:=0 to count-1 do //复制个体，淘汰复制数为0的个体
      begin
        if smp_c[i]>1 then
          begin
            j:=0;
            while smp_c[i]>1 do
             begin
               if smp_c[j]=0 then //淘汰第j个个体，复制第i个个体
                 begin
                   smp_gene[j]:=smp_gene[i];
                   smp_c[i]:=smp_c[i]-1; smp_c[j]:=1;
                 end;
               j:=j+1;
             end;
          end;
       end;}
   end ;




procedure Tform1.roulettePro;//轮盘赌法    这里还有问题（好像以解决了）
var q:array[0..10000] of real;
    tm:array of array of array of real;
    tma:array of array of real;
    j,i,t,k:integer;
    r:real;
//    flag:integer; //控制复制个数的参数
begin
  setlength(tm,count,gcount,grade);
  setlength(tma,count,ys);
  sumf:=0;
  for i:=0 to count-1 do
  begin sumf:=fit[i]+sumf; end;
  //若用户选择使用轮盘赌方法
    q[0]:=0.0;
 for i:=0 to count-1 do     //计算累计概率
   begin
     //if i=0 then q[i]:=0.0;
     q[i+1]:=q[i]+fit[i]/sumf
   end;
//for flag:=0 to count-1 do
 i:=0;
while i<=count-1 do   //产生count个复制染色体
  begin
      //randomize;
      j:=0;
      r:=random(10000)/10000;
     while j<=count-1 do  //查找符合复制条件的染色体
        begin
           if (r>q[j]) and (r<=q[j+1]) then
           begin
             for t:=0 to gcount-1 do
             for k:=0 to grade-1 do
             tm[i][t][k]:=smp[j][t][k];
             for t:=0 to ys-1 do
             tma[i][t]:=qz[j][t];
             {tm[i][0]:=smp_gene[j][0];tm[i][1]:=smp_gene[j][1];
             tm[i][2]:=smp_gene[j][2];tm[i][3]:=smp_gene[j][3];
             tm[i][4]:=smp_gene[j][4];
             //showmessage(inttostr(j+1));}
             i:=i+1;
             break;
           end;
           j:=j+1;       //复制第j+1个染色体
        end;
  end;
for i:=0 to count-1 do
  begin
  for j:=0 to gcount-1 do
   for k:=0 to grade-1 do
   smp[i][j][k]:=tm[i][j][k];
   for j:=0 to ys-1 do
   qz[i][j]:=tma[i][j];
  end;
end;

procedure Tform1.intersectPro;//交叉
var i,j,t,k,t2:integer;
    r:real;
begin
k:=1;

  while k<=count*Pc do
  begin
    i:=trunc(random*(count));
    j:=i;
    while i=j do j:=trunc(random*(count)); //找到两个交叉的个体
    r:=random;            //交叉概率
    if r<=Pc then
    begin
      k:=k+1;
     { if gcount=1 then
      begin
        a1:=trun(smp_gene[i][0],5);       //把两个交叉个体二进制编码
        a2:=trun(smp_gene[j][0],5);       //二进制编码应该为几位？这里处理不完善
        if radiosingle.Checked then       //单点交叉
        begin
          c:=trunc(random*5+1);
          for t:=c+1 to 5 do
            begin
              temp:=a1[t];
              a1[t]:=a2[t];
              a2[t]:=temp;
            end;
        end;
        if radiodouble.Checked then          //两点交叉
        begin
          c:=trunc(random*5+1);
          d:=c;
          while d<>c do d:=trunc(random*5+1);
          if d<c then begin temp:=c;c:=d;d:=trunc(temp);end;
          for t:=c+1 to d-1 do
            begin
              temp:=a1[t];a1[t]:=a2[t];a2[t]:=temp;
            end;
        end;
        if radioequality.Checked then        //均匀交叉
        begin
          for t:=1 to 5 do
          begin
            if random(2)>1 then
            begin
              temp:=a1[t];a1[t]:=a2[t];a2[t]:=temp;
            end;
          end;
        end;
        smp_gene[i][0]:=retrun(a1,5);
        smp_gene[j][0]:=retrun(a2,5);
      end; }
      if gcount>1 then