Szöveg generálása Genetikus
algoritmussal
Írjunk programot, mely egy beviteli mezőben megadható
szöveget állít elő Genetikus algoritmus segítségével.
A program alkalmazza a Genetikus algoritmus
hagyományos lépéseit. Kezdetként állítson elő egy 40 egyedből álló populációt.
A szöveg hosszának felével hajtson végre keresztezéseket a jó egyedek között és
a leggyengébb egyedeket ezekkel helyettesítse. Ha a populáció túlságosan
homogénné válna, akkor alkalmazzon mutációt.
A jóság megfogalmazása büntetőpontokkal történjen.
Minél távolabb van két szöveg egymástól, annál nagyobb legyen a büntetőpont
értéke. Ennek megvalósításához írjunk egy függvényt két azonos hosszúságú
szöveg távolságára. A függvény visszaadott értéke a két szövegben ugyanazon
helyen lévő karaktereknek, kódjaiban mért távolságának összege legyen. Ha a távolság nulla, akkor a két szöveg értelemszerűen
azonos. Generáláskor tehát most minimumot, illetve nulla távolságot fogunk
keresni.
A populáció elemeit egy listadobozban, és finess
értékeit egy mellette illesztett módon elhelyezett másik listadobozban
helyezzük el. A program futása közben a listák akkor frissüljenek, amikor jobb
tulajdonságú elemet találunk az előzőeknél. A generálás maximum kétszázezer
generációig tartson.
A
program futási képe közvetlenül a populáció generálása után:
A
program futási képe generálás közben:
A
program futási képe a keresés befejezés után:
A
program listája:
unit UGenSzov;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls;
Const EgyedSzM=100;
GAl=5;
type
TfmGenSzov = class(TForm)
btKilepes: TButton;
lbSzoveg: TLabel;
edSzoveg: TEdit;
ldGenSzov: TListBox;
lbEgyedSz: TLabel;
edEgyedSz: TEdit;
lbPopSz: TLabel;
edPopSz: TEdit;
lbPopMaxSz: TLabel;
edPopMaxSz: TEdit;
btStart: TButton;
lbKereszt: TLabel;
edKereszt: TEdit;
lbMutSz: TLabel;
edMutSz: TEdit;
btUjPop: TButton;
ldPop: TListBox;
lbMinimum: TLabel;
edMin: TEdit;
Procedure PopKepre;
Procedure PopInit;
Function StrDist(S1, S2: String): Word;
Procedure Keresztez;
Procedure Mutacio;
Procedure Vizsgal;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btUjPopClick(Sender: TObject);
procedure edSzovegChange(Sender: TObject);
procedure edEgyedSzChange(Sender: TObject);
procedure edKeresztChange(Sender: TObject);
procedure edMutSzChange(Sender: TObject);
procedure edPopMaxSzChange(Sender: TObject);
procedure btStartClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TEgyed=Record
ESz: String;
EOK: Word;
EJo: Boolean;
End;
var
fmGenSzov: TfmGenSzov;
Szoveg: String;
EgyedT: Array[1..EgyedSzM] Of TEgyed;
Uj1, Uj2: TEgyed;
EgyedSz, MutSz, Kereszt, ELen: Word;
PopSz, PopMaxSz: LongInt;
IR1, IR2, IJ1, IJ2, OKMin, IMin, OldMin, JokSz: LongInt;
Josag: Real;
implementation
{$R *.dfm}
procedure TfmGenSzov.btKilepesClick(Sender: TObject);
begin
Close;
end;
procedure TfmGenSzov.FormCreate(Sender: TObject);
begin
Randomize; Szoveg:= 'Genetikus algoritmussal';
EgyedSz:= 40; Kereszt:= 11; MutSz:= 1; PopMaxSz:= 200000;
end;
procedure TfmGenSzov.edSzovegChange(Sender: TObject);
begin
Szoveg:= edSzoveg.Text; ELen:= Length(Szoveg);
Kereszt:= ELen Div 2; edKereszt.Text:= IntToStr(Kereszt);
end;
procedure TfmGenSzov.edEgyedSzChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edEgyedSz.Text,EgyedSz,Kod);
end;
procedure TfmGenSzov.edKeresztChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edKereszt.Text,Kereszt,Kod);
end;
procedure TfmGenSzov.edMutSzChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edMutSz.Text,MutSz,Kod);
end;
procedure TfmGenSzov.edPopMaxSzChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edPopMaxSz.Text,PopMaxSz,Kod);
end;
Procedure TfmGenSzov.PopInit;
Var I, J: Word;
Begin
ELen:= Length(Szoveg);
For I:= 1 To EgyedSz Do With EgyedT[I] Do
Begin
SetLength(ESz,ELen); For J:= 1 To ELen Do ESz[J]:= Chr(Random(256));
EOK:= 0; EJo:= False;
End;
End;
Function TfmGenSzov.StrDist(S1, S2: String): Word;
Var I, D: Word;
Begin
D:= 0; StrDist:= D;
If Length(S1)<>Length(S2) Then Exit; ELen:= Length(S1); If ELen=0 Then Exit;
For I:= 1 To ELen Do Inc(D,Abs(Ord(S1[I])-Ord(S2[I]))); StrDist:= D;
End;
Procedure TfmGenSzov.Keresztez;
Var I, V, R: Word;
Begin
Inc(PopSz); edPopSz.Text:= IntToStr(PopSz); edPopSz.Repaint;
SetLength(Uj1.ESz,ELen); SetLength(Uj2.ESz,ELen);
V:= Random(EgyedSz)+1; R:= 0; IR1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do
If Not EJo And (EOK>R) Then Begin R:= EOK; IR1:= I End;
For I:= 1 To V Do With EgyedT[I] Do
If Not EJo And (EOK>R) Then Begin R:= EOK; IR1:= I End;
V:= Random(EgyedSz)+1; R:= 0; IR2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IR1 Then
If Not EJo And (EOK>R)Then Begin R:= EOK; IR2:= I End;
For I:= 1 To V Do With EgyedT[I] Do If I<>IR1 Then
If Not EJo And (EOK>R) Then Begin R:= EOK; IR2:= I End;
V:= Random(EgyedSz)+1; R:= 65000; IJ1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do
If EOK<R Then Begin R:= EOK; IJ1:= I End;
For I:= 1 To V Do With EgyedT[I] Do
If EOK<R Then Begin R:= EOK; IJ1:= I End;
V:= Random(EgyedSz)+1; IJ2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IJ1 Then
If EJo Then IJ2:= I;
For I:= 1 To V Do With EgyedT[I] Do If I<>IJ1 Then
If EJo Then IJ2:= I;
If IJ1*IJ2<>0 Then
Begin
For I:= 1 To Kereszt Do Uj1.ESz[I]:= EgyedT[IJ1].ESz[I];
For I:= Kereszt+1 To ELen Do Uj1.ESz[I]:= EgyedT[IJ2].ESz[I];
For I:= 1 To Kereszt Do Uj2.ESz[I]:= EgyedT[IJ2].ESz[I];
For I:= Kereszt+1 To ELen Do Uj2.ESz[I]:= EgyedT[IJ1].ESz[I];
End;
End;
Procedure TfmGenSzov.Mutacio;
Var I, K: Word;
Begin
Inc(PopSz); edPopSz.Text:= IntToStr(PopSz); edPopSz.Repaint;
For K:= 1 To EgyedSz Do With EgyedT[K] Do
For I:= 1 To ELen Do If Random(1000)<MutSz Then ESz[I]:= Chr(Random(256));
End;
Procedure TfmGenSzov.PopKepre;
Var I: Word;
Begin
With ldGenSzov Do
Begin
Clear;
For I:= 1 To EgyedSz Do Items.Add(EgyedT[I].ESz); RePaint;
End;
With ldPop Do
Begin
Clear;
For I:= 1 To EgyedSz Do Items.Add(IntToStr(StrDist(Szoveg,EgyedT[I].ESz)));
RePaint;
End;
edMin.Text:= IntToStr(OKMin); edMin.RePaint;
End;
procedure TfmGenSzov.btUjPopClick(Sender: TObject);
begin
PopInit; PopKepre; edPopSz.Text:= ''; edMin.Text:= '';
end;
Procedure TfmGenSzov.Vizsgal;
Var K: Word;
Begin
JokSz:= 0; OKMin:= 65000;
For K:= 1 To EgyedSz Do With EgyedT[K] Do
Begin
EOK:= StrDist(Szoveg,ESz);
If EOK<OKMin Then Begin OKMin:= EOK; IMin:= K End;
Inc(JokSz,EOK);
End;
Josag:= JokSz/EgyedSz; JokSz:= 0;
For K:= 1 To EgyedSz Do With EgyedT[K] Do If EOK<Josag Then
Begin Inc(JokSz); EJo:= True End Else EJo:= False;
End;
procedure TfmGenSzov.btStartClick(Sender: TObject);
begin
OKMin:= 65000; IMin:= 0; PopSz:= 1;
Repeat
OldMin:= OKMin; Keresztez;
If (JokSz<GAl) Or (EgyedSz-JokSz<GAl) Then Mutacio Else
If (IR1*IR2<>0) And (IJ1*IJ2<>0) Then
Begin EgyedT[IR1]:= Uj1; EgyedT[IR2]:= Uj2 End;
Vizsgal; If OKMin<OldMin Then PopKepre;
Until (OKMin=0) Or (PopSz>PopMaxSz);
ldGenSzov.ItemIndex:= IMin-1; ldPop.ItemIndex:= IMin-1;
end;
end.
Let’s write a program demonstrating permutational
operators. The well-known operators are the next ones:
- Partial Matched Crossover (PMX)
- Order Crossover (OX)
- Cycle Crossover (CX).
In genetic algorithms
crossover is a genetic operator used to vary the programming of a chromosome
(example: inversion operator) or two chromosomes from one generation to the
next. It is similar to reproduction and biological crossover on which genetic
algorithms are based.
The aim of the crossover
operator is to interchange the information and genes between chromosomes.
Therefore crossover operator combines two parents to reproduce new children,
then one of these children may hopefully collect all good features that exist
in parents.
This screen-shots made in run time, Partial Matched Crossover (PMX):
Order Crossover (OX):
Cycle Crossover (CX):
We have to select in
crossovers to choose number of genes, and in case of PMX and OX two cut spaces.
The genes of parents setup the program (random values), or we fix by +/- signs.
The list of program:
unit UCODemo;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
Const M=32;
FontS=18;
XOrig=320;
YOrigP1=132;
YOrigP2=212;
YOrigC1=332;
YOrigC2=412;
GenM=10;
type
TfmCODemo = class(TForm)
lbCODemo: TLabel;
btExit: TButton;
btP1RND: TButton;
rgCO: TRadioGroup;
btP2RND: TButton;
btCutClear: TButton;
lbCuts: TLabel;
btCrossover: TButton;
edGensNum: TEdit;
lbGensNum: TLabel;
lbChild1: TLabel;
lbChild2: TLabel;
lbCutSet: TLabel;
Procedure GensShow;
Procedure ChildShow;
Procedure GensHide;
Procedure ChildDel;
Procedure ShowCuts;
procedure btExitClick(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormClick(Sender: TObject);
procedure btP1RNDClick(Sender: TObject);
procedure btP2RNDClick(Sender: TObject);
procedure FormDblClick(Sender: TObject);
procedure btCutClearClick(Sender: TObject);
procedure edGensNumChange(Sender: TObject);
procedure btCrossoverClick(Sender: TObject);
procedure rgCOClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
Type
TGen=Class
FNum: Integer;
FX, FY: Integer;
FWidth, FHeight: Word;
FBGColor, FFGColor: TColor;
FSign: Boolean;
Procedure Init(INum, IX, IY, IWidth, IHeight: Integer; ISign: Boolean);
Procedure SetColors(IBGColor, IFGColor: TColor);
Function GetBGColor: TColor;
Procedure Show;
Procedure Hide;
Function GetLeft: Integer;
Function GetTop: Integer;
Function GetNum: Byte;
Procedure SetNum(SNum: Byte);
End;
var
fmCODemo: TfmCODemo;
GenP1, GenP2, GenC1, GenC2: Array[1..GenM] Of TGen;
P1, P2, PX1, PX2, C1, C2: Array[1..GenM] Of Byte;
Parents: Byte;
GenN: Byte;
P1OK, P2OK: Boolean;
MouseX, MouseY: Integer;
ActGen, SelGen, Cut, Cut1, Cut2: Byte;
implementation
{$R *.dfm}
Procedure TGen.Init(INum, IX, IY, IWidth, IHeight: Integer; ISign: Boolean);
Begin
FNum:= INum; FX:= IX; FY:= IY; FWidth:= IWidth; FHeight:= IHeight;
FSign:= ISign;
End;
Procedure TGen.SetColors(IBGColor, IFGColor: TColor);
Begin
FBGColor:= IBGColor; FFGColor:= IFGColor;
End;
Function TGen.GetBGColor: TColor;
Begin
GetBGColor:= FBGColor;
End;
Procedure TGen.Show;
Begin
With fmCODemo.Canvas Do
Begin
Brush.Color:= FBGColor;
Pen.Color:= FFGColor;
RecTangle(FX,FY,FX+FWidth,FY+FHeight);
With Font Do
Begin
Color:= FFGColor;
Size:= FontS;
End;
TextOut(FX+FontS Div 2, FY+2, IntToStr(FNum));
If FSign Then
Begin
Brush.Color:= clBtnFace;
Font.Size:= 14;
TextOut((2*FX+FWidth) Div 2-6,Fy-24,'+');
TextOut((2*FX+FWidth) Div 2-3,Fy+FHeight,'-');
End;
End;
End;
Procedure TGen.Hide;
Begin
With fmCODemo.Canvas Do
Begin
Brush.Color:= clBtnFace;
Pen.Color:= clBtnFace;
RecTangle(FX,FY-24,FX+FWidth,FY+FHeight+24);
End;
End;
Function TGen.GetLeft: Integer;
Begin
GetLeft:= FX;
End;
Function TGen.GetTop: Integer;
Begin
GetTop:= FY;
End;
Function TGen.GetNum: Byte;
Begin
GetNum:= FNum;
End;
Procedure TGen.SetNum(SNum: Byte);
Begin
FNum:= SNum;
End;
procedure TfmCODemo.btExitClick(Sender: TObject);
begin
Close;
end;
procedure TfmCODemo.FormPaint(Sender: TObject);
begin
GensShow;
end;
Procedure TfmCODemo.GensShow;
Var I: Word;
Begin
For I:= 1 To GenN Do
Begin
GenP1[I].Show;
GenP2[I].Show;
GenC1[I].Show;
GenC2[I].Show;
End;
End;
Procedure TfmCODemo.ChildShow;
Var I: Word;
Begin
For I:= 1 To GenN Do
Begin
GenC1[I].Show;
GenC2[I].Show;
End;
End;
Procedure TfmCODemo.GensHide;
Var I: Word;
Begin
For I:= 1 To GenN Do
Begin
GenP1[I].Hide;
GenP2[I].Hide;
GenC1[I].Hide;
GenC2[I].Hide;
End;
End;
Procedure TfmCODemo.ChildDel;
Var I: Word;
Begin
For I:= 1 To GenN Do
Begin
GenC1[I].SetNum(0);
GenC2[I].SetNum(0);
End;
End;
Procedure TfmCODemo.ShowCuts;
Begin
lbCuts.Caption:= IntToStr(Cut1)+' - '+IntToStr(Cut2);
End;
procedure TfmCODemo.FormCreate(Sender: TObject);
Var I: Word;
begin
Randomize;
GenN:= 9; Cut1:= 1; Cut2:= GenN;
For I:= 1 To GenN Do
Begin
GenP1[I]:= TGen.Create;
With GenP1[I] Do
Begin
Init(0,XOrig+(M-1)*(I-1),YOrigP1,M,M, True);
SetColors(clWhite,clBlack);
End;
GenP2[I]:= TGen.Create;
With GenP2[I] Do
Begin
Init(0,XOrig+(M-1)*(I-1),YOrigP2,M,M, True);
SetColors(clWhite,clBlack);
End;
GenC1[I]:= TGen.Create;
With GenC1[I] Do
Begin
Init(0,XOrig+(M-1)*(I-1),YOrigC1,M,M, False);
SetColors(clWhite,clBlack);
End;
GenC2[I]:= TGen.Create;
With GenC2[I] Do
Begin
Init(0,XOrig+(M-1)*(I-1),YOrigC2,M,M, False);
SetColors(clWhite,clBlack);
End;
End;
rgCO.ItemIndex:= 0; P1OK:= False; P2OK:= False;
ShowCuts;
end;
procedure TfmCODemo.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
MouseX:= X; MouseY:= Y;
end;
procedure TfmCODemo.FormClick(Sender: TObject);
begin
ActGen:= 0; Parents:= 0; SelGen:= 0;
If (MouseX<GenP1[1].GetLeft) Or (MouseX>GenP1[GenN].GetLeft+M) Then Exit;
If (MouseY>GenP1[1].GetTop-M) And (MouseY<GenP1[1].GetTop+2*M) Then
Parents:= 1;
If (MouseY>GenP2[1].GetTop-M) And (MouseY<GenP2[1].GetTop+2*M) Then
Parents:= 2;
SelGen:= (MouseX-GenP1[1].GetLeft+M Div 7) Div M +1;
Case Parents Of
1: With GenP1[SelGen] Do
Begin
If (MouseY<GetTop) And (GetNum<GenN) Then SetNum(GetNum+1);
If (MouseY>GetTop+M) And (GetNum>1) Then SetNum(GetNum-1);
Hide; Show;
End;
2: With GenP2[SelGen] Do
Begin
If (MouseY<GetTop) And (GetNum<GenN) Then SetNum(GetNum+1);
If (MouseY>GetTop+M) And (GetNum>1) Then SetNum(GetNum-1);
Hide; Show;
End;
End;
end;
procedure TfmCODemo.btP1RNDClick(Sender: TObject);
Var I, J, K, P: Word;
T: Array[1..GenM] Of Integer;
begin
For I:= 1 To GenN Do T[I]:= I;
For K:= 1 To 10*GenN Do
Begin
I:= Random(GenN)+1; J:= Random(GenN)+1;
P:= T[I]; T[I]:= T[J]; T[J]:= P;
End;
For I:= 1 To GenN Do With GenP1[I] Do
Begin Hide; SetNum(T[I]); Show End;
ChildDel; ChildShow;
P1OK:= True; btCrossover.Enabled:= P1OK And P2OK;
end;
procedure TfmCODemo.btP2RNDClick(Sender: TObject);
Var I, J, K, P: Word;
T: Array[1..GenM] Of Integer;
begin
For I:= 1 To GenN Do T[I]:= I;
For K:= 1 To 10*GenN Do
Begin
I:= Random(GenN)+1; J:= Random(GenN)+1;
P:= T[I]; T[I]:= T[J]; T[J]:= P;
End;
For I:= 1 To GenN Do With GenP2[I] Do
Begin Hide; SetNum(T[I]); Show End;
ChildDel; ChildShow;
P2OK:= True; btCrossover.Enabled:= P1OK And P2OK;
end;
procedure TfmCODemo.FormDblClick(Sender: TObject);
begin
If rgCO.ItemIndex=2 Then Exit;
Cut:= (MouseX-GenP1[1].GetLeft+M Div 7) Div M +1;
With GenP1[Cut] Do Begin SetColors(clYellow,clBlack); Show End;
With GenP2[Cut] Do Begin SetColors(clYellow,clBlack); Show End;
With GenC1[Cut] Do Begin SetColors(clYellow,clBlack); Show End;
With GenC2[Cut] Do Begin SetColors(clYellow,clBlack); Show End;
Cut1:= 1; While GenP1[Cut1].GetBGColor=clWhite Do Inc(Cut1);
Cut2:= GenN; While GenP1[Cut2].GetBGColor=clWhite Do Dec(Cut2);
ShowCuts;
end;
procedure TfmCODemo.btCutClearClick(Sender: TObject);
Var I: Word;
begin
For I:= 1 To GenN Do
Begin
With GenP1[I] Do Begin SetColors(clWhite,clBlack); Show End;
With GenP2[I] Do Begin SetColors(clWhite,clBlack); Show End;
With GenC1[I] Do Begin SetColors(clWhite,clBlack); Show End;
With GenC2[I] Do Begin SetColors(clWhite,clBlack); Show End;
End;
Cut1:= 1; Cut2:= GenN; ShowCuts; ChildDel; ChildShow;
end;
procedure TfmCODemo.edGensNumChange(Sender: TObject);
Var I: Word;
Kod: Integer;
begin
btCutClearClick(Sender); GensHide;
Val(edGensNum.Text,GenN,Kod); If GenN>9 Then GenN:= 9;
edGensNum.Text:= IntToStr(GenN);
For I:= 1 To GenN Do
Begin
GenP1[I].SetNum(0); GenP2[I].SetNum(0);
GenC1[I].SetNum(0); GenC2[I].SetNum(0);
End;
GensShow; Cut1:= 1; Cut2:= GenN; ShowCuts;
P1OK:= False; P2OK:= False; btCrossover.Enabled:= False;
end;
procedure TfmCODemo.btCrossoverClick(Sender: TObject);
Var I, J, A, B, C, P: Word;
begin
For I:= 1 To GenN Do
Begin
P1[I]:= GenP1[I].GetNum; P2[I]:= GenP2[I].GetNum; C1[I]:= 0; C2[I]:= 0;
End;
Case rgCO.ItemIndex Of
0: Begin //PMX (Partially Matched Crossover)
A:= 0; B:= 0;
For I:= Cut1 To Cut2 Do
Begin
For J:= 1 To GenN Do If P1[J]=P2[I] Then A:= J;
For J:= 1 To GenN Do If P2[J]=P1[I] Then B:= J;
P:= P1[I]; P1[I]:= P2[I]; P2[I]:= P;
P:= P1[A]; P1[A]:= P2[B]; P2[B]:= P;
End;
C1:= P1;
C2:= P2;
End;
1: Begin //OX (Order Crossover)
For I:= 1 To GenN Do Begin PX1[I]:= P1[I]; PX2[I]:= P2[I] End;
For I:= Cut1 To Cut2 Do For J:= 1 To GenN Do
If P2[J]=PX1[I] Then P2[J]:= 0;
For I:= Cut1 To Cut2 Do For J:= 1 To GenN Do
If P1[J]=PX2[I] Then P1[J]:= 0;
A:= 0; B:= 0;
For I:= Cut1 To GenN Do
Begin
If P1[I]<>0 Then
Begin
Inc(A); If A=Cut1 Then A:= Cut2+1; PX1[A]:= P1[I];
End;
If P2[I]<>0 Then
Begin
Inc(B); If B=Cut1 Then B:= Cut2+1; PX2[B]:= P2[I];
End;
End;
For I:= 1 To Cut1-1 Do
Begin
If P1[I]<>0 Then
Begin
Inc(A); If A=Cut1 Then A:= Cut2+1; PX1[A]:= P1[I];
End;
If P2[I]<>0 Then
Begin
Inc(B); If B=Cut1 Then B:= Cut2+1; PX2[B]:= P2[I];
End;
End;
For I:= 1 To Cut1 Do P1[I]:= PX1[I];
For I:= Cut1 To Cut2 Do P1[I]:= PX2[I];
For I:= Cut2+1 To GenN Do P1[I]:= PX1[I];
For I:= 1 To Cut1 Do P2[I]:= PX2[I];
For I:= Cut1 To Cut2 Do P2[I]:= PX1[I];
For I:= Cut2+1 To GenN Do P2[I]:= PX2[I];
C1:= P1;
C2:= P2;
End;
2: Begin //CX (Cycle Crossover)
For I:= 1 To GenN Do Begin PX1[I]:= 0; PX2[I]:= 0 End;
For I:= 1 To GenN Do If P1[I]=P2[I] Then
Begin PX1[I]:= P1[I]; PX2[I]:= P2[I] End;
A:= 1;
While PX1[A]<>0 Do Inc(A); B:= A;
Repeat
PX1[A]:= P1[A];
PX2[A]:= P2[A];
C:= 0; For J:= 1 To GenN Do
If P1[J]=PX2[A] Then C:= J; A:= C;
Until A=B;
For I:= 1 To GenN Do
Begin
If PX1[I]=0 Then PX1[I]:= P2[I];
If PX2[I]=0 Then PX2[I]:= P1[I];
End;
C1:= PX1;
C2:= PX2;
End;
End;
For I:= 1 To GenN Do
Begin GenC1[I].SetNum(C1[I]); GenC2[I].SetNum(C2[I]) End;
GensShow;
end;
procedure TfmCODemo.rgCOClick(Sender: TObject);
begin
If rgCO.ItemIndex=2 Then
Begin
btCutClearClick(Sender);
btCutClear.Enabled:= False;
End Else btCutClear.Enabled:= True;
end;
end.
Bűvös négyzet készítése Genetikus
algoritmussal
Bűvös négyzet alatt olyan négyzetes számtáblázatot
értünk, amelynek soraiban, oszlopaiban és átlóiban elhelyezkedő számok összege
mindig ugyanaz. Az átlók mellett néha az átlókkal párhuzamosan elhelyezkedő
(mellékátlókban lévő) számok összegét is be szokták venni ebbe a kritériumba,
néha csak bizonyos számokat, például csak prímeket, néha tetszőleges számokat
írhatunk a négyzetekbe.
Az alap bűvös négyzetekben mindig 1-től n2-ig
szerepelnek a számok. Ebben a fejezetben ilyen bűvös négyzetek generálásáról
lesz szó. A generálást genetikus algoritmus segítségével fogjuk megoldani.
Egyedeknek az 1-től n2-ig terjedő számok
egy permutációját fogjuk tekinteni. Egy populációban maximum 40 egyedet fogunk
szerepeltetni, míg a generációk maximális számát 10000-ben határozzuk meg. Ezek
értékeket természetesen az algoritmus beindítása előtt módosíthatók.
Az egyedek minősítése (fitness értéke, ami most inkább
bad points-nak lenne mondható) a következő: minden n-re a program az egyedek
generálásakor megállapítja a bűvös szám értékét, azaz kiszámolja 1-től n2-ig
a számok összegét és osztja n-el. Ennek kellene lenni minden összegnek a sorokban,
oszlopokban és a két átlóban. A fitness érték úgy adódik, hogy minden sorban és
oszlopban, valamint a két átlóban meghatározzuk a tényleges összegeket, vesszük
mindegyiknek az eltérését a szükséges értéktől és összeadjuk az így kapott
2*n+2 darab számot. Ez egy véletlen feltöltés esetén nagyobb, mint 0. Minél
kisebb ez az összeg annál jobbnak tartunk egy egyedet. Ha az összeg 0, akkor a
táblázat egy bűvös négyzet.
A genetikus algoritmus lépései a következők:
A 0. generáció
előállítása, mely 40 db permutációja az 1-n2 számoknak.
Szelekciónál két jó minősítésű (a fitness értékek átlagánál
kisebb) egyedet választunk a keresztezéshez szülőként. Az egyik szülő mindig
olyan, hogy nála jobb tulajdonságú nincs a populációban.
Keresztezésnél a következőre kell figyelnünk: az egyedek
önmagukban hordozzák azt a megkövetelt tulajdonságot (fenotípusát), hogy csupa
különböző számból állnak. Az egyszerű egy, vagy többpontos keresztezéseknél
könnyen adódna olyan egyed, mely ezt a tulajdonságát elveszítené, életképtelenné
lenne. Az életképtelen egyedek kiszűrése külön problémát és az algoritmus
szempontjából fölösleges lépések sokaságát jelentené. Csak olyan keresztezési
módszert engedhetünk meg, amelyek a permutációkon újra permutációkat (csupa
különböző géneket) állít elő az egyes egyedeken belül. Három ilyen keresztezési
módszer közül választhatunk a generálás előtt:
- Partially Matched Crossover (PMX), mely egy két vágási pontos keresztezés, melynél a
vágási pontok közötti gének helyet cserélnek, majd a kialakított génpárok
segítségével a gének kicserélésre kerülnek.
- Order Crossover (OX), mely szintén egy kétpontos keresztezés, ahol a
szülőkből a gének a ciklikus sorrendjük megtartásával kerülnek át az utódokba.
- Cycle Crossover (CX), mely vágási pont nélküli keresztezés, melyben a
gének egymásba kapcsolásával egy ciklust hozunk létre. A ciklusban szereplő
egyedek az utódokban ugyanott szerepelnek, míg a ciklusból kimaradt gének
kicserélődnek. (Itt az is előfordulhat, hogy a gének teljes láncot alkotnak,
vagy csak egyelemű láncot, és ekkor az utódok génkészlete a szülőkkel
megegyezik.)
Mutációnál az alapértelmezett értéket 30-nak állítottam be,
amely 0,3 valószínűségű változtatást jelent a populáció minden rossz egyedének
minden génjére. A jó egyedek génjeninél egy 5 értékű rátát alkalmaz az
algoritmus, valamint a legjobb egyed génjeit nem változtatja.
Mind keresztezésnél, mind a mutációnál csak olyan
egyedek kerülhetnek az új populációba, melyek lényegesen nem rosszabb
tulajdonságúak, mint elődeik. Nevezetesen a megengedett romlás 5%-nyi. A
sikertelen egyedgenerálást ellenére a program új generációként kezeli az ebben
az esetben változatlanul hagyott populációt is (ha nem így lenne akkor nem
vennénk észre a beragadást egy állapotba, külön figyelni kellene erre is egy
változóval, melyet ki kellene íratni).
A
továbbiakban n=3-tól n=11-ig egy-egy screenshot-on megtekinthetjük a generált
bűvös nézeteket. A 40 egyed fitness értékeit és a génjeit is megjeleníti a
program, de génekből csak maximum az első 17-et.
A
program listája:
unit UGenBuv;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, ExtCtrls;
Const Max=20;
EgyedSzM=100;
GAL=3;
type
TfmGenBuv = class(TForm)
lbGenBuv: TLabel;
btKilepes: TButton;
lbNegyzOld: TLabel;
edNOld: TEdit;
btStart: TButton;
sgGenBuv: TStringGrid;
sgEgyed: TStringGrid;
btUjPop: TButton;
edPopSz: TEdit;
edKesz: TEdit;
lbPopSz: TLabel;
lbFitness: TLabel;
lbKereszt: TLabel;
rgKereszt: TRadioGroup;
lbBuvosSz: TLabel;
edBuvosSz: TEdit;
lbIndex: TLabel;
edIndex: TEdit;
lbPopSzM: TLabel;
edPopSzM: TEdit;
lbEgyedSz: TLabel;
edEgyedSz: TEdit;
edMutSz: TEdit;
lbMutSz: TLabel;
Procedure PopInit;
Procedure Josaga(E: Word);
Procedure Vizsgal;
Procedure PopKepre;
Procedure Tablara(E: Word);
Procedure Keresztez;
Procedure Mutacio;
procedure btKilepesClick(Sender: TObject);
procedure btStartClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure edNOldChange(Sender: TObject);
procedure btUjPopClick(Sender: TObject);
procedure edPopSzMChange(Sender: TObject);
procedure edEgyedSzChange(Sender: TObject);
procedure edMutSzChange(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TSzam=Record
NN: Array[1..Max*Max] Of Word;
End;
TEgyed=Record
ENN: TSzam;
EOK: Word;
EJo: Boolean;
End;
var
fmGenBuv: TfmGenBuv;
EgyedT: Array[0..EgyedSzM] Of TEgyed;
Josag: Real;
Uj1, Uj2: TEgyed;
EgyedSz, NOld, Tablan, JokSz, Ker1, Ker2, Kozep, OsszJo: Word;
IR1, IR2, IJ1, IJ2, OKMin, IMin, OldMin, MutSz: Word;
PopSz, PopSzM: LongInt;
implementation
{$R *.dfm}
procedure TfmGenBuv.btKilepesClick(Sender: TObject);
begin
Close;
end;
procedure TfmGenBuv.FormCreate(Sender: TObject);
Var I: Integer;
begin
Randomize;
EgyedSz:= 40; Mutsz:= 30; PopSz:= 1; PopSzM:= 10000;
rgKereszt.ItemIndex:= 0;
btStart.Enabled:= False;
With sgEgyed Do
Begin
RowCount:= EgyedSz+1;
For I:= 1 To ColCount-2 Do Cells[I,0]:= IntToStr(I);
For I:= 1 To RowCount-1 Do Cells[0,I]:= IntToStr(I);
Cells[ColCount-1,0]:= 'Fit';
End;
end;
procedure TfmGenBuv.edPopSzMChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edPopSzM.Text,PopSzM,Kod);
end;
procedure TfmGenBuv.edEgyedSzChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edEgyedSz.Text,EgyedSz,Kod);
end;
procedure TfmGenBuv.edMutSzChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edMutSz.Text,MutSz,Kod);
end;
procedure TfmGenBuv.edNOldChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edNOld.Text,NOld,Kod); If NOld<3 Then NOld:= 3;
edNOld.Text:= IntToStr(NOld);
btStart.Enabled:= False;
end;
Procedure TfmGenBuv.PopInit;
Var I, J, K, L, P: Word;
T: TSzam;
Begin
For I:= 1 To Max*Max Do T.NN[I]:= I;
For K:= 1 To EgyedSz Do With EgyedT[K] Do
Begin
For L:= 1 To Max*Max*Max Do
Begin
Repeat
I:= Random(NOld*NOld)+1;
J:= Random(NOld*NOld)+1;
Until I<>J;
P:= T.NN[I]; T.NN[I]:= T.NN[J]; T.NN[J]:= P;
End;
ENN:= T;
EOK:= 0;
EJo:= False;
End;
End;
Procedure TfmGenBuv.Josaga(E: Word);
Var I, J, N, S: Word;
V: Array[1..Max,1..Max] Of Word;
Begin
With EgyedT[E] Do
Begin
For I:= 1 To NOld*NOld Do V[(I-1) Mod NOld+1,(I-1) Div NOld+1]:= ENN.NN[I];
S:= 0;
For I:= 1 To NOld Do
Begin
N:= 0; For J:= 1 To NOld Do Inc(N,V[I,J]); Inc(S,Abs(N-Kozep));
N:= 0; For J:= 1 To NOld Do Inc(N,V[J,I]); Inc(S,Abs(N-Kozep));
End;
N:= 0; For J:= 1 To NOld Do Inc(N,V[J,J]); Inc(S,Abs(N-Kozep));
N:= 0; For J:= 1 To NOld Do Inc(N,V[J,NOld-J+1]); Inc(S,Abs(N-Kozep));
EOK:= S;
End;
End;
Procedure TfmGenBuv.Vizsgal;
Var I: Word;
Begin
OsszJo:= 0; OKMin:= 65000; IMin:= 1;
For I:= 1 To EgyedSz Do With EgyedT[I] Do
Begin Inc(OsszJo,EOK); If EOK<OKMin Then Begin OKMin:= EOK; IMin:= I End End;
Josag:= OsszJo/EgyedSz;
For I:= 1 To EgyedSz Do With EgyedT[I] Do If EOK<Josag Then
EJo:= True Else EJo:= False;
End;
Procedure TfmGenBuv.PopKepre;
Var I, J: Word;
Begin
With sgEgyed Do
Begin
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
For J:= 1 To EgyedSz Do With EgyedT[J] Do For I:= 1 To NOld*NOld Do
Begin
Cells[I,J]:= IntToStr(ENN.NN[I]);
Cells[ColCount-1,J]:= IntToStr(EOK);
End;
End;
End;
Procedure TfmGenBuv.Tablara(E: Word);
Var I: Word;
Begin
With sgGenBuv Do For I:= 1 To NOld*NOld Do
Cells[(I-1) Mod NOld+1,(I-1) Div NOld+1]:= IntToStr(EgyedT[E].ENN.NN[I]);
End;
Procedure TfmGenBuv.Keresztez;
Var I, J, V, R, A, B, C, P, T, U: Word;
P1, P2: TSzam;
Van: Boolean;
Begin
Inc(PopSz);
V:= Random(EgyedSz)+1; R:= 0; IR1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do
If Not EJo And (EOK>R) Then Begin R:= EOK; IR1:= I End;
For I:= 1 To V Do With EgyedT[I] Do
If Not EJo And (EOK>R) Then Begin R:= EOK; IR1:= I End;
V:= Random(EgyedSz)+1; R:= 0; IR2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IR1 Then
If Not EJo And (EOK>R)Then Begin R:= EOK; IR2:= I End;
For I:= 1 To V Do With EgyedT[I] Do If I<>IR1 Then
If Not EJo And (EOK>R) Then Begin R:= EOK; IR2:= I End;
V:= Random(EgyedSz)+1; R:= 65000; IJ1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do
If EJo And (EOK<R) Then Begin R:= EOK; IJ1:= I End;
For I:= 1 To V Do With EgyedT[I] Do
If EJo And (EOK<R) Then Begin R:= EOK; IJ1:= I End;
V:= Random(EgyedSz)+1; IJ2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IJ1 Then
If EJo Then IJ2:= I;
For I:= 1 To V Do With EgyedT[I] Do If I<>IJ1 Then
If EJo Then IJ2:= I;
//keresztezés -> Uj1, Uj2: TEgyed
If IJ1*IJ2*IR1*IR2<>0 Then
Begin
Uj1:= EgyedT[IJ1];
Uj2:= EgyedT[IJ2];
Case rgKereszt.ItemIndex Of
0: Begin //PMX (Partially Matched Crossover)
A:= 0; B:= 0;
For I:= Ker1+1 To Ker2 Do
Begin
For J:= 1 To NOld*NOld Do
If Uj1.ENN.NN[J]=Uj2.ENN.NN[I] Then A:= J;
For J:= 1 To NOld*NOld Do
If Uj2.ENN.NN[J]=Uj1.ENN.NN[I] Then B:= J;
P:= Uj1.ENN.NN[I];
Uj1.ENN.NN[I]:= Uj2.ENN.NN[I];
Uj2.ENN.NN[I]:= P;
P:= Uj1.ENN.NN[A];
Uj1.ENN.NN[A]:= Uj2.ENN.NN[B];
Uj2.ENN.NN[B]:= P;
End;
End;
1: Begin //OX (Order Crossover)
P1:= Uj1.ENN;
P2:= Uj2.ENN;
For I:= Ker1+1 To Ker2 Do For J:= 1 To NOld*NOld Do
If Uj2.ENN.NN[J]=P1.NN[I] Then Uj2.ENN.NN[J]:= 0;
For I:= Ker1+1 To Ker2 Do For J:= 1 To NOld*NOld Do
If Uj1.ENN.NN[J]=P2.NN[I] Then Uj1.ENN.NN[J]:= 0;
A:= 0; B:= 0;
For I:= Ker1+1 To NOld*NOld Do
Begin
If Uj1.ENN.NN[I]<>0 Then
Begin
Inc(A); If A=Ker1+1 Then A:= Ker2+1; P1.NN[A]:= Uj1.ENN.NN[I];
End;
If Uj2.ENN.NN[I]<>0 Then
Begin
Inc(B); If B=Ker1+1 Then B:= Ker2+1; P2.NN[B]:= Uj2.ENN.NN[I];
End;
End;
For I:= 1 To Ker1 Do
Begin
If Uj1.ENN.NN[I]<>0 Then
Begin
Inc(A); If A=Ker1+1 Then A:= Ker2+1; P1.NN[A]:= Uj1.ENN.NN[I];
End;
If Uj2.ENN.NN[I]<>0 Then
Begin
Inc(B); If B=Ker1+1 Then B:= Ker2+1; P2.NN[B]:= Uj2.ENN.NN[I];
End;
End;
With Uj1.ENN Do
Begin
For I:= 1 To Ker1 Do NN[I]:= P1.NN[I];
For I:= Ker1+1 To Ker2 Do NN[I]:= P2.NN[I];
For I:= Ker2+1 To NOld*NOld Do NN[I]:= P1.NN[I];
End;
With Uj2.ENN Do
Begin
For I:= 1 To Ker1 Do NN[I]:= P2.NN[I];
For I:= Ker1+1 To Ker2 Do NN[I]:= P1.NN[I];
For I:= Ker2+1 To NOld*NOld Do NN[I]:= P2.NN[I];
End;
End;
2: Begin //CX (Cycle Crossover)
For I:= 1 To NOld*NOld Do Begin P1.NN[I]:= 0; P2.NN[I]:= 0 End;
For I:= 1 To NOld*NOld Do If Uj1.ENN.NN[I]=Uj2.ENN.NN[I] Then
Begin P1.NN[I]:= Uj1.ENN.NN[I]; P2.NN[I]:= Uj2.ENN.NN[I] End;
A:= 1;
While P1.NN[A]<>0 Do Inc(A); B:= A;
Repeat
P1.NN[A]:= Uj1.ENN.NN[A];
P2.NN[A]:= Uj2.ENN.NN[A];
C:= 0; For J:= 1 To NOld*NOld Do
If Uj1.ENN.NN[J]=P2.NN[A] Then C:= J; A:= C;
Until A=B;
For I:= 1 To NOld*NOld Do
Begin
If P1.NN[I]=0 Then P1.NN[I]:= Uj2.ENN.NN[I];
If P2.NN[I]=0 Then P2.NN[I]:= Uj1.ENN.NN[I];
End;
Uj1.ENN:= P1;
Uj2.ENN:= P2;
End;
End;
EgyedT[0]:= Uj1; Josaga(0); T:= EgyedT[0].EOK;
EgyedT[0]:= Uj2; Josaga(0); U:= EgyedT[0].EOK;
If T+U<=1.05*(EgyedT[IR1].EOK+EgyedT[IR2].EOK) Then
Begin
EgyedT[IR1]:= Uj1; Josaga(IR1);
EgyedT[IR2]:= Uj2; Josaga(IR2);
End;
End;
End;
Procedure TfmGenBuv.Mutacio;
Var I, J, K, L, P, U: Word;
T: TSzam;
Begin
Inc(PopSz);
For L:= 1 To EgyedSz Do With EgyedT[L] Do
If L<>IMin Then For K:= 1 To NOld Do
If Not EJo And (Random(100)<MutSz) Or EJo And (Random(100)<MutSz/5) Then
Begin
U:= EOK;
T:= ENN;
Repeat
I:= Random(NOld*NOld)+1;
J:= Random(NOld*NOld)+1;
Until I<>J;
P:= T.NN[I]; T.NN[I]:= T.NN[J]; T.NN[J]:= P;
EgyedT[0].ENN:= T;
Josaga(0);
If EgyedT[0].EOK<=1.05*U Then ENN:= T;
End;
End;
procedure TfmGenBuv.btStartClick(Sender: TObject);
Var I: Word;
begin
rgKereszt.Enabled:= False;
btUjPop.Enabled:= False;
OKMin:= 65000; IMin:= 0; PopSz:= 1;
Repeat
OldMin:= OKMin; edPopSz.Text:= IntToStr(PopSz); edPopSz.Repaint;
If IJ1*IJ2*IR1*IR2<>0 Then Keresztez Else
Begin Mutacio; For I:= 1 To EgyedSz Do Josaga(I) End;
Vizsgal; PopKepre; sgEgyed.Repaint;
If OKMin<OldMin Then
Begin
edKesz.Text:= IntToStr(OKMin); edKesz.Repaint;
edIndex.Text:= IntToStr(IMin); edIndex.Repaint;
Tablara(IMin); sgGenBuv.Repaint;
End;
Until (OKMin=0) Or (PopSz>PopSzM);
Tablara(IMin);
rgKereszt.Enabled:= True;
btUjPop.Enabled:= True;
end;
procedure TfmGenBuv.btUjPopClick(Sender: TObject);
Var I, J: Word;
Kod: Integer;
begin
Val(edNOld.Text,NOld,Kod);
Kozep:= (NOld*NOld*(NOld*NOld+1) Div 2) Div NOld;
edBuvosSz.Text:= IntToStr(Kozep);
Ker1:= NOld*NOld Div 3; Ker2:= 2*NOld*NOld Div 3;
With sgGenBuv Do
Begin
DefaultColWidth:= 42;
DefaultRowHeight:= 36;
Width:= 43*NOld+7;
Height:= 37*NOld+5;
ColCount:= NOld+2;
RowCount:= NOld+2;
ColWidths[0]:= 0;
RowHeights[0]:= 0;
ColWidths[ColCount-1]:= 0;
RowHeights[RowCount-1]:= 0;
Col:= ColCount-1;
Row:= RowCount-1;
For I:= 0 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
Visible:= True;
End;
PopInit;
For I:= 1 To EgyedSz Do Josaga(I);
Vizsgal;
PopKepre;
btStart.Enabled:= True;
end;
end.