?? 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.
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -