ga.~pas

此遗传算法功能强大

unit ga;

interface

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


type
  TForm1 = class(TForm)
	MainMenu1: TMainMenu;
	N1: TMenuItem;
	Panel1: TPanel;
	Label1: TLabel;
	GroupBox1: TGroupBox;
	ComboBox1: TComboBox;
	Label2: TLabel;
	Label3: TLabel;
	ComboBox2: TComboBox;
	Label4: TLabel;
	Label5: TLabel;
	Label6: TLabel;
	ComboBox3: TComboBox;
	ComboBox4: TComboBox;
	ComboBox5: TComboBox;
	GroupBox2: TGroupBox;
	Label7: TLabel;
	Label8: TLabel;
	Edit1: TEdit;
	Edit2: TEdit;
	Label9: TLabel;
	Edit3: TEdit;
	GroupBox3: TGroupBox;
	StartButton: TButton;
	ResetButton: TButton;
	GroupBox4: TGroupBox;
	N2: TMenuItem;
	N3: TMenuItem;
	N4: TMenuItem;
	ListView1: TListView;
	XPManifest1: TXPManifest;
	GroupBox5: TGroupBox;
	Label10: TLabel;
	Label11: TLabel;
	Edit4: TEdit;
	Edit5: TEdit;
	Label12: TLabel;
	Label13: TLabel;
	Edit6: TEdit;
	N5: TMenuItem;
  ProgressBar1: TProgressBar;
  TrackBar1: TTrackBar;
  Label14: TLabel;
  N6: TMenuItem;
  N7: TMenuItem;
  N8: TMenuItem;
  GroupBox6: TGroupBox;
  PaintBox1: TPaintBox;
	procedure StartButtonClick(Sender: TObject);
	procedure ResetButtonClick(Sender: TObject);
	procedure N2Click(Sender: TObject);
	procedure N5Click(Sender: TObject);
  procedure N4Click(Sender: TObject);
  procedure N7Click(Sender: TObject);
  procedure N8Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Math;

const
	MostPopSize = 1000; //允许的最大的群体大小
	MostChromSize = 1000; //允许的最大的染色体大小

var
	PopSize,ChromSize: Integer; //实际的群体大小，实际的染色体（个体）大小
	Pop,MidPop: array[1..MostPopSize,1..MostChromSize] of Integer; //始末群体，中间群体
	MatingPool: array[1..MostPopSize] of Integer; //中间群体的交配池
	Fit,InitFit: array[1..MostPopSize] of Double;
	TotalFit,EvenFit: Double; //总适应度，平均适应度
	MostFitChrom,LeastFitChrom: Integer; //最大适应度的个体 ，最小适应度的个体
	P_CrossOver,P_Mutation: Real; // 交叉概率，变异概率
	MostGeneration: Integer; //最大的有效遗传代数
	ZoneUpperLimit: Real; //所求函数的上限
	ZoneLowerLimit: Real; //所求函数的下限
	BestAnswer_X,BestAnswer_Y: Double; //GA所求得的最优解
	SumMutation,SumCrossOver: Integer;//变异次数,交叉次数

{$R *.dfm}

Function ChromToInt(chrom: Integer): Integer;
var power,j,ChromInt: Integer;
begin
	ChromInt := 0;
	power := 1;
	For j:=ChromSize DownTo 1 Do
		begin
			ChromInt := ChromInt+Pop[chrom][j]*power;
			power := power*2;
		end;
	result := ChromInt;
end;

procedure Encode();//编码
var i,j: Integer;
begin
	Randomize;
	For i:=1 To PopSize Do
		For j:=1 To ChromSize Do
			Pop[i][j] := Random(2);
end;

procedure Decode(const X_Only: boolean);//解码
var ChromInt: Integer;
begin
	ChromInt := ChromToInt(PopSize+1);
	BestAnswer_X := ZoneLowerLimit+(ZoneUpperLimit-ZoneLowerLimit)*ChromInt/(Power(2,ChromSize)-1);
	if not X_Only then
	BestAnswer_Y := Sqr(BestAnswer_X)-4*BestAnswer_X+4;
end;

procedure CalculateFit(const MaxValue: boolean);//计算个体适应度
var ChromInt,i: Integer;
	Answer_X: Double;
begin
	For i:=1 To PopSize Do
		begin
			ChromInt := ChromToInt(i);
			Answer_X := ZoneLowerLimit+(ZoneUpperLimit-ZoneLowerLimit)*ChromInt/(Power(2,ChromSize)-1);
			If MaxValue=true then
				Fit[i] :=Sqr(Answer_X)-4*Answer_X+4
			else
				begin
					Fit[i] :=Sqr(Answer_X)-4*Answer_X+4;
					Fit[i] := 1/Fit[i];
				end
		end;
end;

procedure Replacement();//寻找最优个体
var j: Integer;
begin
	//替换掉这一代中适应度最小的染色体
	If Fit[LeastFitChrom] < Fit[PopSize+1] Then
	begin
		Fit[LeastFitChrom] := Fit[PopSize+1]; // 上一代适应度最大者
		//Pop[LeastFitChrom] := Pop[PopSize+1]; //复制对应的染色体
		For j:=1 To ChromSize Do
			Pop[LeastFitChrom][j] := Pop[PopSize+1][j];
	end
	else ;
	If Fit[MostFitChrom] > Fit[PopSize+1] Then
	begin
		Fit[PopSize+1] := Fit[MostFitChrom]; // "后起之秀"
		For j:=1 To ChromSize Do//复制对应的染色体
		Pop[PopSize+1][j] := Pop[MostFitChrom][j];
	end
	else;
end;

procedure EvaluateFit();//评价适应度
var i: Integer;
begin
	TotalFit := 0;
	MostFitChrom := PopSize+1;
	LeastFitChrom := 1;
	For i:=1 To PopSize Do
		begin
			TotalFit := TotalFit+Fit[i];
			If Fit[i] > Fit[MostFitChrom] Then
				begin
					MostFitChrom := i;
				end
				else
				If Fit[i] < Fit[LeastFitChrom] Then
					begin
						LeastFitChrom := i;
					end
				else ;
		end;
	EvenFit := TotalFit/PopSize;
	Replacement(); //小型优胜劣汰
end;

procedure Selection();//选择操作
var
  pick,fitSum,sum:Real;
  popNum,i,j:Integer;
begin
  Randomize;
  sum := 0.0;
	popNum :=1;
	fitSum :=0.0;
  while popNum<=PopSize do
    begin
      pick :=Random;
      sum :=TotalFit*pick;
      if(TotalFit<>0)then
				begin
					i :=1;
          fitSum := 0.0;
          while sum>=fitSum do
            begin
							fitSum :=fitSum+Fit[i];
							i :=i+1;
            end;
					For j:=1 To ChromSize Do
						MidPop[popNum][j] := Pop[i-1][j];
					popNum:=popNum+1;
				end;
		end;
end;

procedure GoThoughMatingPool();
var temp: Integer; //暂存被选中的Chrom的相邻前一个chrom
	i: Integer;
begin
	For i:=1 To PopSize Do MatingPool[i]:=i;
		Randomize;
		i :=PopSize;
    repeat
			temp := MatingPool[i-1];
			MatingPool[i-1] := Random(i-1)+1;
			MatingPool[MatingPool[i-1]] := temp;
			i := i-2;
    until i<1;
end;

procedure ChromSwap(const i,MateChrom,j: Integer);
begin
	If MidPop[i][j] <> MidPop[MateChrom][j] Then
		begin
			MidPop[i][j] := 1-MidPop[i][j];
			MidPop[MateChrom][j] := 1-MidPop[MateChrom][j];
		end
    else
end;//对配对的两个基因(i和MateChrom)在基因座j上交叉

procedure CrossOver(); //按交叉概率执行交叉算子
var i,j: Integer;
	MateChrom: Integer;
	Crosspos: Integer;
	MidChromSize: Integer;
begin
	GoThoughMatingPool();
	Randomize;
	i :=1;
	repeat
		MateChrom := MatingPool[i+1];
		If random <= P_CrossOver Then  //满足交叉概率
			begin
				SumCrossOver :=SumCrossOver+1;
				CrossPos := Random(ChromSize-1)+1;
				MidChromSize := trunc(ChromSize/2);
				If CrossPos <= MidChromSize Then
					For j:=1 To CrossPos Do
						ChromSwap(i,MateChrom,j)
				else
				For j:= CrossPos DownTo ChromSize Do
					ChromSwap(i,MateChrom,j);
			end
		else ;
		For j:=1 To ChromSize Do
			Pop[i][j] := MidPop[i][j];
		For j:=1 To ChromSize Do
			Pop[MateChrom][j] := Pop[MateChrom][j];
			i := i+2;
    until i>PopSize;
end;

procedure Mutation();//变异操作
var
  i,MutationPosition :Integer;
  begin
    Randomize;
		for i :=1 to PopSize do
      begin
        if(Random<=P_Mutation)then
          begin
            MutationPosition:=Random(ChromSize)+1;
            if Pop[i][MutationPosition]=1 then
							 Pop[i][MutationPosition] := 0
            else Pop[i][MutationPosition] := 1;
            SumMutation:=SumMutation+1;
          end
      end
end;

Function IsMostGenerationNow(generation: Integer):boolean;
begin
	result := generation = MostGeneration;
end;

function ParameterCheck():boolean;//检查输入参数
var info: String;
	Zone,MidMutation: Double;
begin
  MidMutation :=0.05;
	Zone := ZoneUpperLimit-ZoneLowerLimit;
  If (ZoneLowerLimit>ZoneUpperLimit) Then
    info := info+'区间取值本末倒置[-1000000000,1000000000];'+#13;
  If (ZoneLowerLimit <-1000000000.0) or (ZoneUpperLimit >1000000000.0) Then
    info := info+'区间取值溢出[-1000000000,1000000000];'+#13;
  If (PopSize <50) or (PopSize >500) then
    info := info+'种群个数取值溢出[50,200];'+#13;
  If  ChromSize < log2(Zone) then
    info := info+'基因长度太小['+IntToStr(Trunc(log2(Zone)))+',31]'+#13;
  If (P_CrossOver <0.5) or (P_CrossOver >=1.0) then
    info := info+'交叉概率取值溢出[0.5,1.0);'+#13;
  If (P_Mutation <0.001) or (P_Mutation>MidMutation)then
    info := info+'变异概率取值溢出[0.001,0.05];'+#13;
  If info='' then
    result := true
  else
  begin
    ShowMessage(info);
    result :=false;
  end;
end;

procedure TForm1.ResetButtonClick(Sender: TObject);//重设参数
begin
  listview1.Clear;
	ComboBox1.Text :='50';
	ComboBox2.Text :='100';
	ComboBox3.Text :='8';
	ComboBox4.Text :='0.5';
	ComboBox5.Text :='0.001';
	Edit1.Text :='0';
	Edit2.Text :='0';
	Edit3.Text :='0';
	Edit4.Text :='0';
	Edit5.Text :='50';
	Edit6.Text :='0';
  ProgressBar1.Position :=0;
  TrackBar1.Position :=0;
end;

procedure TForm1.N2Click(Sender: TObject);
begin
  N2.Checked :=true;
  N5.Checked :=false;
end;

procedure TForm1.N5Click(Sender: TObject);
begin
  N2.Checked :=false;
  N5.Checked :=true;
end;

procedure TForm1.N4Click(Sender: TObject);
begin
  showmessage('遗传算法'+#13+'版本1.0.0'+#13+'版权所有 (C) 2005.05.1 '+#13+'开发成员：林喜鹏、何泽荣、张学文'+#13+'（华南农业大学02级计算机(1)班）');
end;

procedure Delay(msecs:integer);//延时单位为毫秒
var
  FirstTickCount:longint;
begin
  FirstTickCount:=GetTickCount;
  repeat
    Application.ProcessMessages;
  until ((GetTickCount-FirstTickCount) >= Longint(msecs));
end;

//寻优绘图
procedure ChromToPaintArea(const Chrom: Integer;var X,Y: Integer);//求出Chrom在PaintBox中的对应位置
begin
	X := ChromToInt(Chrom);
  Y := Sqr(X)-4*X+4;
  X := (X mod 500)+5;
  Y := Y mod 500+5;
end;

procedure ChromPainter(Sender: Tobject);//在PaintBox中绘出Chrom的所在
var
	Chrom_X,Chrom_Y: Integer;
  i: Integer;
  rc: trect;
  //PaintBox: TpaintBox;
begin
  tpaintbox(sender).Color:=clskyblue;
  rc.left:=0;rc.top:=0;rc.right:=522;rc.bottom:=512;
  (sender as TPaintBox).Canvas.FillRect(rc);
	For i:=1 To PopSize Do
  	begin
    	ChromToPaintArea(i,Chrom_X,Chrom_Y);
      (sender as TPaintBox).Canvas.Ellipse(Chrom_X-2,Chrom_Y-2,Chrom_X+2,Chrom_Y+2);
    end;
end;

procedure TForm1.StartButtonClick(Sender: TObject);//主过程
var
  NewItem: TListItem;
  generation: Integer;
begin
	listview1.clear;
  ResetButton.Enabled :=false;
	Fit:=InitFit;
	ZoneLowerLimit:=StrToFloat(Edit4.Text);//所求函数的下限
	ZoneUpperLimit:=StrToFloat(Edit5.Text);//所求函数的上限
	PopSize:=StrToInt(ComboBox1.Text);//设定的群体大小
	MostGeneration:=StrToInt(ComboBox2.Text);//设定的最大的遗传代数
	ChromSize:=StrToInt(ComboBox3.Text);//染色体大小
	P_CrossOver:=StrToFloat(ComboBox4.Text);//交叉概率
	P_Mutation:=StrToFloat(ComboBox5.Text);//变异概率
  Edit1.Text :='0';
	Edit2.Text :='0';
	Edit3.Text :='0';
  Edit6.Text :='0';
  ProgressBar1.Max :=MostGeneration;
	if ParameterCheck() then
		begin
			generation := 1;
			SumMutation := 0;
			SumCrossOver :=0;
			Encode(); //把解空间编码到GA搜索空间
			CalculateFit(N5.Checked); //计算各个适应度
			EvaluateFit(); //评价适应度
			repeat
        ChromPainter(PaintBox1);//寻优绘图
        Decode(true);// 只对X译码
				NewItem := ListView1.Items.Add;
				NewItem.Caption :=IntToStr(generation);
				NewItem.SubItems.Add (format('%.6f',[BestAnswer_X]));
				NewItem.SubItems.Add (format('%.6f',[TotalFit]));
				NewItem.SubItems.Add (format('%.6f',[EvenFit]));
				NewItem.SubItems.Add (format('%.6f',[Fit[PopSize+1]]));
				Selection(); //按赌轮盘算法筛选优良染色体
				CrossOver(); //按交叉概率执行交叉算子
				Mutation(); //按变异概率执行变异算子
				CalculateFit(N5.Checked); //计算各个适应度
				EvaluateFit(); //评价适应度
        ProgressBar1.Position :=generation;
				generation := generation+1;
        Delay(TrackBar1.Position);
        TrackBar1.Hint :=IntToStr(TrackBar1.Position)+'ms';
			until generation > MostGeneration; //已经达到最大的遗传代数
			Decode(false); //把从GA搜索空间的最优染色体译码到解空间
			Edit1.Text :=IntToStr(SumMutation);
			Edit2.Text :=IntToStr(SumCrossOver);
			Edit3.Text :=format('%.6f',[BestAnswer_X]);
			Edit6.Text :=format('%.6f',[BestAnswer_Y]);
      ProgressBar1.Position := 0;
      ResetButton.Enabled :=true;
		end
	else ;
end;

procedure TForm1.N7Click(Sender: TObject);
begin
  GroupBox6.Visible :=false;
  GroupBox4.Visible :=true;
  N7.Checked :=true;
  N8.Checked :=false;
end;

procedure TForm1.N8Click(Sender: TObject);
begin
  GroupBox4.Visible :=false;
  GroupBox6.Visible :=true;
  N8.Checked :=true;
  N7.Checked :=false;
end;

end.