注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

鑫淼梦园的博客

圆你的梦想 从这里开始

 
 
 

日志

 
 

遗传算法Delphi版  

2014-01-12 11:14:28|  分类: 遗传算法 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

遗传算法Delphi版

2008-05-29 09:22:01|  分类: 算法|字号 订阅

unit UnitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, DB, ADODB, DateUtils;

type
  TForm1 = class(TForm)
    Button2: TButton;
    ADOQuery1: TADOQuery;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    EdTestCount: TEdit;
    procedure initialize;
    function BiToDec(BiString: string): Int64;
    function Evaluate(xstr: string): Double;
    procedure Select;
    procedure Crossover;
    procedure Mutation;
    procedure Button2Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
    population: array[0..39] of string; //父代群体
    childrenpopulation: array[0..39] of string;
    bestresult: Double;
    bestgeneration: Integer;
    farray: array[0..39] of Double;
    bestroot: string;
    sumf, mutationprobability: Double;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Crossover;
var
  i, j, crossoverpos: Integer;
  parent1, parent2: string;
  temp: char;
begin
  i := 0;
  while i < 40 do
  begin
    parent1 := childrenpopulation[i];
    parent2 := childrenpopulation[i + 1];

    Randomize;
    crossoverpos := Random(22);
    if (crossoverpos = 0) or (crossoverpos = 1) then
    else
    begin
      for j := crossoverpos to 22 do
      begin
        temp := parent1[j];
        parent1[j] := parent2[j];
        parent2[j] := temp;
      end;
    end;
    childrenpopulation[i] := parent1;
    childrenpopulation[i + 1] := parent2;
    i := i + 2;
  end;
end;

function TForm1.Evaluate(xstr: string): Double;
var
  xdouble: Double;
begin
  xdouble := BiToDec(xstr);
  xdouble := -1.0 + xdouble * 3 / 4194304;
  result := xdouble * Sin(10 * Pi * xdouble) + 2.0;
end;

//将二进制串转换为十进制整数
function TForm1.BiToDec(BiString: string): Int64;
var
  i, strlen, coefficient: Integer;
begin
  strlen := Length(BiString);
  coefficient := 1;
  result := 0;
  for i := strlen downto 1 do
  begin
    if BiString[i] <> '0' then
      result := result + coefficient;
    coefficient := coefficient * 2;
  end;
end;
//初始化群体
procedure TForm1.initialize;
var
  individual: array[0..21] of char;
  i, j: Integer;
begin

  Randomize;
  for j := 0 to 39 do
  begin
    for i := 0 to 21 do
    begin      
      if Random > 0.5 then
        individual[i] := '1'
      else
        individual[i] := '0';
    end;
    population[j] := individual;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  i, j, generationcount, CTestCount, TestCount: Integer;
  DBpath, ConStr, SqlStr: string;
  begintime, ctime: TDateTime;
begin
  mutationprobability := 0.001;
  generationcount := 49;
  begintime := Now;
  TestCount := StrToIntDef(EdTestCount.Text, 100);
  for CTestCount := 1 to TestCount do
  begin
    Label2.Caption := '当前是第' + IntToStr(CTestCount) + '次实验';
    application.ProcessMessages;

    initialize; //初始化群体
    for j := 0 to generationcount do
    begin

      for i := 0 to 39 do
      begin
        SqlStr := 'INSERT INTO [POPULATION]([SelectMethod],[TestCount],[GENERATION], [INDIVIDAUL_INDEX],[BISTR],[VALUE])'
          + ' values(''roulette wheel selection'','
          + IntToStr(CTestCount) + ','
          + IntToStr(j) + ','
          + IntToStr(i) + ','
          + ''''+population[i] + ''','
          + FloatToStr((-1.0 + BiToDec(population[i]) * 3 / 4194304)) + ')';
        ADOQuery1.SQL.Clear;
        ADOQuery1.SQL.Add(SqlStr);
        ADOQuery1.ExecSQL;
      end;
      
      sumf := 0;
      bestresult := 0;
      //计算个体适应度*******************************************************
      for i := 0 to 39 do
      begin
        farray[i] := Evaluate(population[i]);
        sumf := sumf + farray[i];
        if farray[i] >= bestresult then //记录最优个体
        begin
          bestresult := farray[i];
          bestroot := population[i];
        end;
      end;
      //*********************************************************************
      //选择
      Select;
      Crossover;
      Mutation;
      for i := 0 to 39 do
        population[i] := childrenpopulation[i];

      SqlStr := 'INSERT INTO [TESTDATA]([SelectMethod],[TestCount],[GenerationCount], [MaxValue],[BestRoot])'
        + ' values(''roulette wheel selection'','
        + IntToStr(CTestCount) + ','
        + IntToStr(j) + ','
        + FloatToStr(bestresult) + ','
        + FloatToStr((-1.0 + BiToDec(bestroot) * 3 / 4194304)) + ')';
      ADOQuery1.SQL.Clear;
      ADOQuery1.SQL.Add(SqlStr);
      ADOQuery1.ExecSQL;
      Label1.Caption := '当前是第' + IntToStr(j) + '代';
      ctime := Now;
      Label3.Caption := '耗时' + IntToStr(MilliSecondsBetween(begintime, ctime)) + '毫秒';
      application.ProcessMessages;
    end;
  end;
  Showmessage('完成!');
end;

procedure TForm1.Mutation;
var
  i, mutationpos: Integer;
begin
  for i := 0 to 39 do
  begin
    Randomize;
    if mutationprobability > Random then
    begin
      Randomize;
      mutationpos := Random(22);
      if mutationpos <> 0 then
      begin
        if childrenpopulation[i][mutationpos] = '0' then
          childrenpopulation[i][mutationpos] := '1'
        else
          childrenpopulation[i][mutationpos] := '0';
      end;
    end;
  end;
end;


procedure TForm1.Select;
var
  SelectProbability, Pi: Double;
  i, j: Integer;
begin
  for i := 0 to 39 do
  begin
    Randomize;
    SelectProbability := Random; //选择概率
    Pi := 0;
    for j := 0 to 39 do
    begin
      Pi := Pi + farray[j] / sumf;
      if SelectProbability < Pi then
      begin
        childrenpopulation[i] := population[j];
        break;
      end;
    end;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  DBpath, ConStr, SqlStr: string;
begin
  DBpath := ExtractFileDir(application.ExeName) + '\TestData.mdb';
 { ConStr := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='
    + DBpath
    + ';Persist Security Info=False';  }
  ConStr := 'Provider=SQLOLEDB.1;Password=wq;Persist Security Info=True;'
    + 'User ID=sa;Initial Catalog=GA_DATA;Data Source=.';
  ADOQuery1.ConnectionString := ConStr;
end;

end.

  评论这张
 
阅读(373)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017