unit1.pas

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

      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;
          c:=trunc(random*(ys-1)+1);
          for t:=c+1 to ys do
            begin
              temp:=qz[i][t-1];
              qz[i][t-1]:=qz[j][t-1];
              qz[j][t-1]:=temp;
            end;
           gya;
        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;
          c:=trunc(random*ys+1);
          d:=c;
          while d<>c do d:=trunc(random*ys+1);
            //找到两个不同 不要位置的基因
          if d<c then begin temp:=c;c:=d;d:=trunc(temp);end;

          for t:=c+1 to d-1 do

            begin
              temp:=qz[i][t-1];
              qz[i][t-1]:=qz[j][t-1];
              qz[j][t-1]:=temp;    //交叉
            end;
            gya;
        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;
          for t:=1 to ys do
           begin
            if random(2)>1 then             //确定该位是否交叉
            begin
              temp:=qz[i][t-1];
              qz[i][t-1]:=qz[j][t-1];
              qz[j][t-1]:=temp;   //交叉
            end;
          end;
        gya;
        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.