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.