unit1.~pas

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

    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;
    j,i,t,k:integer;
    r:real;
//    flag:integer; //控制复制个数的参数
begin
  setlength(tm,count,gcount,grade);
  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];
             {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
  for j:=0 to gcount-1 do
   for k:=0 to grade-1 do
   smp[i][j][k]:=tm[i][j][k];
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
      begin
        if radiosingle.Checked then        //单点交叉
        begin
          c:=trunc(random*(gcount-1)+1);
          c2:=trunc(random*(grade-1)+1);
          for t:=c+1 to gcount do
           for t2:=c2+1 to grade do               //交叉
            begin
              temp:=smp[i][t-1][t2-1];
              smp[i][t-1][t2-1]:=smp[j][t-1][t2-1];
              smp[j][t-1][t2-1]:=temp;
            end;
           gy;
        end;
        if radiodouble.Checked then      //两点交叉
        begin
          c:=trunc(random*gcount+1); c2:=trunc(random*grade+1);
          d:=c; d2:=c2;
          while d<>c do d:=trunc(random*gcount+1);
          while d2<>c2 do d:=trunc(random*grade+1);  //找到两个不同 不要位置的基因
          if d<c then begin temp:=c;c:=d;d:=trunc(temp);end;
          if d2<c2 then begin temp:=c2;c2:=d2;d2:=trunc(temp);end;
          for t:=c+1 to d-1 do
           for t2:=c2+1 to d2-1 do
            begin
              temp:=smp[i][t-1][t2-1];
              smp[i][t-1][t2-1]:=smp[j][t-1][t2-1];
              smp[j][t-1][t2-1]:=temp;    //交叉
            end;
            gy;
        end;
        if Radioequality.Checked then         //均匀交叉
        begin
          for t:=1 to gcount do
           for t2:=1 to grade do
          begin
            if random(2)>1 then             //确定该位是否交叉
            begin
              temp:=smp[i][t-1][t2-1];
              smp[i][t-1][t2-1]:=smp[j][t-1][t2-1];
              smp[j][t-1][t2-1]:=temp;   //交叉
            end;
          end;
        gy;
        end;
      end;
    end;
  end;
end;


procedure Tform1.aberrancePro;//变异  有问题！！！！
var i,j,k,t,t2,tys:integer;
    r:real;
begin
  k:=1;

  while k<=count*gcount*Pm do
  begin
    tys:=trunc(random*(ys));
   // tdata:=trunc(random*(data));
    t2:=trunc(random*(count));
    i:=trunc(random*(gcount));
    j:=trunc(random*(grade));
    //if gcount=1 then  j:=trunc(random*(5)); //这是一个基因时的编码问题
    r:=random;
    if r<=Pm then
    begin
      k:=k+1;
     { if gcount=1 then
      begin
        a1:=trun(smp_gene[i][0],5);
        if a1[j+1]=0 then a1[j+1]:=0 else a1[j+1]:=0;
        smp_gene[i][0]:=retrun(a1,5);
      end;  }
      if gcount>1 then
      begin
         { if clb.Checked[j]=false then
          begin
            smp[i][j][t2]:=random*trunc(interval[j][0]
                  -interval[j][grade])+interval[j][grade];
            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]]);
          end
          else
          begin
            smp_gene[i][j]:=random*trunc(interval[j][gcount]
                  -interval[j][0])+interval[j][0];
          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]]);
          end;}
            {case j of                         //有错
            0,1,2,3:
            smp_gene[i][j]:=trunc(random(trunc(interval[j][4]
            -interval[j][0]))+interval[j][0]); //
                  4: smp_gene[i][j]:=random*interval[j][0];                        //有错
          end;}
          if smp[t2][i][j]<>1 then
          smp[t2][i][j]:=smp[t2][i][j]+random*0.05;
          if qz[t2][tys]<>1 then
          qz[t2][tys]:=qz[t2][tys]+random*0.05;
          gya;
          gy;
      end;
    end;
  end;
end;

function trun(const number:real;const l:integer):TSmpouts;
//十进制—>二进制转换
  var i,num:integer;
begin
  num:=trunc(number);
  for i:=l downto 1 do
  begin
  result[i]:=num mod 2; num:=num div 2;
  end;
end;

function retrun(const a:Tsmpouts;const l:integer):real;
var i:integer;
begin
  result:=0;
  for i:=1 to l do
  begin
    result:=result*2+a[i]
  end;
end;








procedure TForm1.Button1Click(Sender: TObject);
var i,j:integer;
begin
 grade:=gcount;
  for i:=0 to gcount-1 do   //初始化bx,ax,gx
    begin
      if i<=0 then
        begin
          interval[i][0]:=0.5333;interval[i][1]:=0.2667;
          interval[i][2]:=0.1333;interval[i][3]:=0.0667;
          interval[i][4]:=0;
        end
      else  if i=1 then
              begin
                interval[i][0]:=0.2105;interval[i][1]:=0.4211;
                interval[i][2]:=0.2105;interval[i][3]:=0.1053;
                interval[i][4]:=0.0526;
              end
      else  if i=2 then
              begin
                interval[i][0]:=0.1;interval[i][1]:=0.2;
                interval[i][2]:=0.4;interval[i][3]:=0.2;
                interval[i][4]:=0.1;
              end
      else  if i=3 then
              begin
                interval[i][0]:=0.0526;interval[i][1]:=0.1053;
                interval[i][2]:=0.2105;interval[i][3]:=0.4211;
                interval[i][4]:=0.2105;
              end
            else  begin
                    interval[i][0]:=0;interval[i][1]:=0.0667;
                    interval[i][2]:=0.1333;interval[i][3]:=0.2667;
                    interval[i][4]:=0.5333;
                  end;
    end;
  for i:=0 to gcount-1 do
  begin
 //     StringGrid1.Cells[0,i+1]:=
             // f_sj.Grid1.Cells[i+1,0];
       // '基因 '+inttostr(StringGrid1.RowCount-1);
    for j:=0 to grade-1 do
    StringGrid1.Cells[j+1,i+1]:=floattostr(interval[i][j])
  end;
  {vle.Values['等级 1']:='-1.5';
  vle.Values['等级 2']:='-0.5';
  vle.Values['等级 3']:='0.5';
  vle.Values['等级 4']:='1.5';
  clb.Checked[4]:=true;}
  stringgrid2.Cells[0,0]:='0.166';stringgrid2.Cells[1,0]:='0.1336';stringgrid2.Cells[2,0]:='0.0202';
  stringgrid2.Cells[3,0]:='0.2551';stringgrid2.Cells[4,0]:='0.1255';stringgrid2.Cells[5,0]:='0.0769';
  stringgrid2.Cells[6,0]:='0.0446';stringgrid2.Cells[7,0]:='0.1579';stringgrid2.Cells[8,0]:='0.0202';
  stringgrid3.Cells[0,0]:='1';stringgrid3.Cells[1,0]:='2';stringgrid3.Cells[2,0]:='3';
  stringgrid3.Cells[3,0]:='3';stringgrid3.Cells[4,0]:='3';stringgrid3.Cells[5,0]:='2';
  stringgrid3.Cells[6,0]:='3';stringgrid3.Cells[7,0]:='3';stringgrid3.Cells[8,0]:='1';
  stringgrid4.Cells[0,0]:='3';
  stringgrid3.Cells[0,1]:='2';stringgrid3.Cells[1,1]:='5';stringgrid3.Cells[2,1]:='1';
  stringgrid3.Cells[3,1]:='4';stringgrid3.Cells[4,1]:='5';stringgrid3.Cells[5,1]:='1';
  stringgrid3.Cells[6,1]:='3';stringgrid3.Cells[7,1]:='5';stringgrid3.Cells[8,1]:='5';
  stringgrid4.Cells[0,1]:='4';
  stringgrid3.Cells[0,2]:='3';stringgrid3.Cells[1,2]:='5';stringgrid3.Cells[2,2]:='5';
  stringgrid3.Cells[3,2]:='4';stringgrid3.Cells[4,2]:='5';stringgrid3.Cells[5,2]:='1';
  stringgrid3.Cells[6,2]:='5';stringgrid3.Cells[7,2]:='5';stringgrid3.Cells[8,2]:='5';
  stringgrid4.Cells[0,2]:='5';
  stringgrid3.Cells[0,3]:='1';stringgrid3.Cells[1,3]:='5';stringgrid3.Cells[2,3]:='3';
  stringgrid3.Cells[3,3]:='4';stringgrid3.Cells[4,3]:='5';stringgrid3.Cells[5,3]:='1';
  stringgrid3.Cells[6,3]:='1';stringgrid3.Cells[7,3]:='4';stringgrid3.Cells[8,3]:='2';
  stringgrid4.Cells[0,3]:='4';
  stringgrid3.Cells[0,4]:='1';stringgrid3.Cells[1,4]:='5';stringgrid3.Cells[2,4]:='1';
  stringgrid3.Cells[3,4]:='5';stringgrid3.Cells[4,4]:='4';stringgrid3.Cells[5,4]:='1';
  stringgrid3.Cells[6,4]:='5';stringgrid3.Cells[7,4]:='4';stringgrid3.Cells[8,4]:='5';
  stringgrid4.Cells[0,4]:='4';
  stringgrid3.Cells[0,5]:='1';stringgrid3.Cells[1,5]:='4';stringgrid3.Cells[2,5]:='3';
  stringgrid3.Cells[3,5]:='4';stringgrid3.Cells[4,5]:='5';stringgrid3.Cells[5,5]:='1';
  stringgrid3.Cells[6,5]:='5';stringgrid3.Cells[7,5]:='4';stringgrid3.Cells[8,5]:='3';
  stringgrid4.Cells[0,5]:='4';
  stringgrid3.Cells[0,6]:='3';stringgrid3.Cells[1,6]:='5';stringgrid3.Cells[2,6]:='4';
  stringgrid3.Cells[3,6]:='4';stringgrid3.Cells[4,6]:='2';stringgrid3.Cells[5,6]:='1';
  stringgrid3.Cells[6,6]:='5';stringgrid3.Cells[7,6]:='4';stringgrid3.Cells[8,6]:='3';
  stringgrid4.Cells[0,6]:='4';
  stringgrid3.Cells[0,7]:='1';stringgrid3.Cells[1,7]:='5';stringgrid3.Cells[2,7]:='3';
  stringgrid3.Cells[3,7]:='4';stringgrid3.Cells[4,7]:='5';stringgrid3.Cells[5,7]:='1';
  stringgrid3.Cells[6,7]:='1';stringgrid3.Cells[7,7]:='4';stringgrid3.Cells[8,7]:='3';
  stringgrid4.Cells[0,7]:='4';
  stringgrid3.Cells[0,8]:='2';stringgrid3.Cells[1,8]:='5';stringgrid3.Cells[2,8]:='3';
  stringgrid3.Cells[3,8]:='5';stringgrid3.Cells[4,8]:='4';stringgrid3.Cells[5,8]:='1';
  stringgrid3.Cells[6,8]:='5';stringgrid3.Cells[7,8]:='4';stringgrid3.Cells[8,8]:='5';
  stringgrid4.Cells[0,8]:='4';
  stringgrid3.Cells[0,9]:='2';stringgrid3.Cells[1,9]:='5';stringgrid3.Cells[2,9]:='1';
  stringgrid3.Cells[3,9]:='4';stringgrid3.Cells[4,9]:='4';stringgrid3.Cells[5,9]:='1';
  stringgrid3.Cells[6,9]:='3';stringgrid3.Cells[7,9]:='4';stringgrid3.Cells[8,9]:='2';
  stringgrid4.Cells[0,9]:='4';
  label7.Visible:=true;
  label8.Visible:=true;
  label9.Visible:=true;
  label10.Visible:=true;
   memo1.Clear;
  memo2.Clear;
end;

{procedure TFrm_transmit.Button3Click(Sender: TObject);
begin
form_gene.showmodal;
end;}

procedure TForm1.BitBtn1Click(Sender: TObject);
var i,n:integer;
begin
  {while (vle.RowCount>1) and (vle.Keys[1]<>'') do
  begin
    vle.Strings.Delete(0);
  end;}
  n:=strtoint(editstate.Text);
  //for i:=1 to n do
  //vle.InsertRow('等级 '+inttostr(i),'',true);
  grade:=n;
  UI_init;
  stringgrid3.ColCount:=strtoint(edit2.Text);
  stringgrid3.RowCount:=strtoint(e_10.Text);
  stringgrid4.RowCount:=strtoint(e_10.Text);
  stringgrid2.ColCount:=strtoint(edit2.text);
  stringgrid5.RowCount:=strtoint(e_10.Text);
end;

procedure TForm1.showDT(n:integer;memo1:Tmemo);
var i,j,k:integer;str:string;
begin
  memo1.Clear;
  Label6.Caption:='进化代数为 '+inttostr(n);
  for i:=0 to count-1 do
  begin
    str:='';
    for j:=0 to gcount-1 do
    for k:=0 to grade-1 do
    str:=format(str+'%8f',[smp[i][j][k]]);
    Memo1.Lines.Add('('+str+')--输--出-->'+floattostr(outs[i]));
  end;
end;

procedure TForm1.showDT1(n:integer;memo1:Tmemo);
var i,j:integer;str,str1:string;
begin
  memo1.Clear;
  str:='';
  str1:='';
  Label6.Caption:='进化代数为 '+inttostr(n);
  for i:=0 to gcount-1 do
  begin
  str:='';
  //str1:=format(str1+'%8.4f',[result1[i]]);
  for j:=0 to grade-1 do
  begin
    str:=format(str+'%8.4f',[ybmm[i][j]]);
   end;
   Memo1.Lines.Add('('+str+')');
   end;
  for i:=0 to ys-1 do
  str1:=format(str1+'%8.4f',[qzmm[i]]);

  memo1.lines.add('');
  memo1.lines.add('输出值样本');
  memo1.lines.add('');
  Memo1.Lines.Add('('+str1+')');
  memo1.lines.add('');
  Memo1.Lines.Add('--输--出-->'+floattostr(ymm));

end;


{procedure TFrm_transmit.BitBtn2Click(Sender: TObject);
//var i:integer;
begin
showmessage(vle.Keys[0]);
end;}


end.