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, MessagesSysUtilsVariantsClasses

  GraphicsControlsFormsDialogsStdCtrls;

Const EgyedSzM=100;
      GAl=5;

type
  TfmGenSzov = class(TForm)
    btKilepesTButton;
    lbSzovegTLabel;
    edSzovegTEdit;
    ldGenSzovTListBox;
    lbEgyedSzTLabel;
    edEgyedSzTEdit;
    lbPopSzTLabel;
    edPopSzTEdit;
    lbPopMaxSzTLabel;
    edPopMaxSzTEdit;
    btStartTButton;
    lbKeresztTLabel;
    edKeresztTEdit;
    lbMutSzTLabel;
    edMutSzTEdit;
    btUjPopTButton;
    ldPopTListBox;
    lbMinimumTLabel;
    edMinTEdit;
    Procedure PopKepre;
    Procedure PopInit;
    Function StrDist(S1, S2: String): Word;
    Procedure Keresztez;
    Procedure Mutacio;
    Procedure Vizsgal;
    procedure btKilepesClick(SenderTObject);
    procedure FormCreate(SenderTObject);
    procedure btUjPopClick(SenderTObject);
    procedure edSzovegChange(SenderTObject);
    procedure edEgyedSzChange(SenderTObject);
    procedure edKeresztChange(SenderTObject);
    procedure edMutSzChange(SenderTObject);
    procedure edPopMaxSzChange(SenderTObject);
    procedure btStartClick(SenderTObject);
  private
    Private declarations }
  public
    Public declarations }
  end;

  TEgyed=Record
    ESzString;
    EOK: Word;
    EJoBoolean;
  End;

var
  fmGenSzovTfmGenSzov;
  SzovegString;
  EgyedTArray[1..EgyedSzM] Of TEgyed;
  Uj1, Uj2: TEgyed;
  EgyedSzMutSz, Kereszt, ELen: Word;
  PopSzPopMaxSzLongInt;
  IR1, IR2, IJ1, IJ2, OKMinIMinOldMinJokSzLongInt;
  JosagReal;

implementation

{$R *.dfm}

procedure TfmGenSzov.btKilepesClick(SenderTObject);
begin
  Close;
end;

procedure TfmGenSzov.FormCreate(SenderTObject);
begin
  RandomizeSzoveg:= 'Genetikus algoritmussal';
  EgyedSz:= 40; Kereszt:= 11; MutSz:= 1; PopMaxSz:= 200000;
end;

procedure TfmGenSzov.edSzovegChange(SenderTObject);
begin
  Szoveg:= edSzoveg.TextELen:= Length(Szoveg);
  Kereszt:= ELen Div 2; edKereszt.Text:= IntToStr(Kereszt);
end;

procedure TfmGenSzov.edEgyedSzChange(SenderTObject);
Var Kod: Integer;
begin
  Val(edEgyedSz.Text,EgyedSz,Kod);
end;

procedure TfmGenSzov.edKeresztChange(SenderTObject);
Var Kod: Integer;
begin
  Val(edKereszt.Text,Kereszt,Kod);
end;

procedure TfmGenSzov.edMutSzChange(SenderTObject);
Var Kod: Integer;
begin
  Val(edMutSz.Text,MutSz,Kod);
end;

procedure TfmGenSzov.edPopMaxSzChange(SenderTObject);
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 ExitELen:= 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(SenderTObject);
begin
  PopInitPopKepreedPopSz.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/EgyedSzJokSz:= 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(SenderTObject);
begin
  OKMin:= 65000; IMin:= 0; PopSz:= 1;
  Repeat
    OldMin:= OKMin; Keresztez;
    If (JokSz<GAlOr (EgyedSz-JokSz<GAlThen Mutacio Else
    If (IR1*IR2<>0) And (IJ1*IJ2<>0) Then
    Begin EgyedT[IR1]:= Uj1; EgyedT[IR2]:= Uj2 End;
    VizsgalIf OKMin<OldMin Then PopKepre;
  Until (OKMin=0) Or (PopSz>PopMaxSz);
  ldGenSzov.ItemIndex:= IMin-1; ldPop.ItemIndex:= IMin-1;
end;

end.