Автор: Mystic
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Генетические алгоритмы

Класс, реализующий генетический алгоритм.

Зависимости: Classes, SysUtils, Windows, Math
Автор:       Mystic, mystic2000@newmail.ru, ICQ:125905046, Харьков
Copyright:   Mystic
Дата:        25 апреля 2002 г.
***************************************************** }

unit Genes;

interface

uses {Fuzzy,}  Classes, SysUtils, Windows, Math;

type
  TGeneAlgorithm = class;
  TExtendedArray = array of Extended;

  TEstimateEvent = procedure(Sender: TObject; const X: TExtendedArray; var Y:
    Extended) of object;
  TIterationEvent = procedure(Sender: TObject; Iteration: Integer);
  TBestChangeEvent = procedure(Sender: TObject; BestEstimate: Extended);

  EGeneError = class(Exception)
  end;

  TCardinalArray = array of Cardinal;
  TGeneRecord = record
    Bits: TCardinalArray;
    Values: TExtendedArray;
    Estimate: Extended;
  end;
  TGeneRecords = array of TGeneRecord;

  TSolutionThread = class(TThread)
  private
    FOwner: TGeneAlgorithm;
  protected
    procedure Execute; override;
    property Owner: TGeneAlgorithm read FOwner;
  public
    constructor Create(AOwner: TGeneAlgorithm);
  end;

  TGeneState = (gsExecute, gsSuspend, gsTune);

  TGeneAlgorithm = class
  private
    FData: array of TGeneRecord; // Algorithm data
    FLock: TRTLCriticalSection;
    FLowValues: TExtendedArray;
    FHighValues: TExtendedArray;
    FSolutionThread: TSolutionThread;
    FMutation: Extended;
    FInversion: Extended;
    FCrossover: Extended;
    FMaxPopulation: Integer;
    FBitPerNumber: Integer;
    FMinPopulation: Integer;
    FDimCount: Integer;
    FOnBestChange: TBestChangeEvent;
    FOnEstimate: TEstimateEvent;
    FOnIteration: TIterationEvent;
    FIteration: Integer;
    // FBestEstimate: Extended;
    FState: TGeneState;

    BitSize: Integer;

    function GetBestEstimate: Extended;
    function GetHighValues(I: Integer): Extended;
    function GetIteration: Integer;
    function GetLowValues(I: Integer): Extended;
    procedure SetBitPerNumber(const Value: Integer);
    procedure SetCrossover(const Value: Extended);
    procedure SetDimCount(const Value: Integer);
    procedure SetHighValues(I: Integer; const Value: Extended);
    procedure SetInversion(const Value: Extended);
    procedure SetLowValues(I: Integer; const Value: Extended);
    procedure SetMaxPopulation(const Value: Integer);
    procedure SetMinPopulation(const Value: Integer);
    procedure SetMutation(const Value: Extended);
    procedure SetOnBestChange(const Value: TBestChangeEvent);
    procedure SetOnEstimate(const Value: TEstimateEvent);
    procedure SetOnIteration(const Value: TIterationEvent);
    procedure Lock;
    procedure Unlock;
    function GetBestX(I: Integer): Extended;
    function GetState: TGeneState;

    procedure DoCrossover(N: Integer);
    procedure DoMutation(N: Integer);
    procedure DoInversion(N: Integer);

    procedure EstimatePopulation(StartIndex: Integer);
    procedure SortPopulation;
    procedure MakeChild;

  public
    // Creation & destroying
    constructor Create;
    destructor Destroy; override;

    // Running / stopping
    procedure Run;
    procedure Abort;
    procedure Suspend;
    procedure Resume;

    // Saving / opening
    procedure LoadFromStream(S: TStream);
    procedure SaveToStream(S: TStream);

    // Algorithm param
    property BitPerNumber: Integer read FBitPerNumber write SetBitPerNumber;
    property MaxPopulation: Integer read FMaxPopulation write SetMaxPopulation;
    property MinPopulation: Integer read FMinPopulation write SetMinPopulation;
    property Crossover: Extended read FCrossover write SetCrossover;
    property Mutation: Extended read FMutation write SetMutation;
    property Inversion: Extended read FInversion write SetInversion;
    property DimCount: Integer read FDimCount write SetDimCount;
    property LowValues[I: Integer]: Extended read GetLowValues write
      SetLowValues;
    property HighValues[I: Integer]: Extended read GetHighValues write
      SetHighValues;

    // Info property
    property Iteration: Integer read GetIteration;
    property BestX[I: Integer]: Extended read GetBestX;
    property BestEstimate: Extended read GetBestEstimate;
    property State: TGeneState read GetState;

    // Events
    property OnEstimate: TEstimateEvent read FOnEstimate write SetOnEstimate;
    property OnIteration: TIterationEvent read FOnIteration write
      SetOnIteration;
    property OnBestChange: TBestChangeEvent read FOnBestChange write
      SetOnBestChange;

  end;

implementation

resourcestring
  SCannotSetParam = 'Невозможно установить параметр %s в состоянии %s';
  SCannotGetParam = 'Невозможно прочитать параметр %s в состоянии %s';
  SInvalidParam = 'Параметр %s не может быть %s (%d).';
  SNonPositive = 'отрицательным или нулевым';
  SInvalidProbality = 'вероятность %s должна быть в диапазоне 0..1 (%f).';
  SLess2 = 'меньше двух';
  SEmpty =
    'Неправильный индекс при обращении к %s (%d) при нулевом количества элементов.';
  SInvalidIndex =
    'Неправильный индекс при обращении к %s (%d). Индекс должен лежать в диапазоне от %d до %d';
  SNonEstimate = 'Не задана функция оценки.';

const
  SState: array[TGeneState] of string = (
    'настройки параметров алгоритма',
    'работы алгоритма',
    'остановки алгоритма');

  { TGeneAlgorithm }

procedure TGeneAlgorithm.Abort;
var
  I: Integer;
begin
  if FState = gsExecute then
  begin
    FSolutionThread.Terminate;
    FSolutionThread.WaitFor;
  end;
  Lock;
  try
    for I := 0 to Length(FData) - 1 do
    begin
      SetLength(FData[I].Bits, 0);
      SetLength(FData[I].Values, 0);
    end;
    SetLength(FData, 0);
    FState := gsTune;
  finally
    Unlock;
  end;
end;

constructor TGeneAlgorithm.Create;
begin
  InitializeCriticalSection(FLock);
  FBitPerNumber := 8;
  FMinPopulation := 5000;
  FMaxPopulation := 10000;
  FMutation := 0.1;
  FCrossover := 0.89;
  FInversion := 0.01;
  FDimCount := 0;
  FState := gsTune;
end;

destructor TGeneAlgorithm.Destroy;
begin
  Abort;
  DeleteCriticalSection(FLock);
  SetLength(FLowValues, 0);
  SetLength(FHighValues, 0);
  inherited;
end;

procedure TGeneAlgorithm.DoCrossover(N: Integer);
var
  I: Integer;
  Parent1, Parent2: Integer;
  Bit, ByteCount: Integer;
  BitPos: Byte;
  Mask: Integer;
begin
  Parent1 := Random(FMinPopulation);
  Parent2 := Random(FMinPopulation);
  Bit := Random(FDimCount * FBitPerNumber - 1);
  ByteCount := Bit div 32;
  for I := 0 to ByteCount - 1 do
    FData[N].Bits[I] := FData[Parent1].Bits[I];
  for I := ByteCount + 1 to BitSize - 1 do
    FData[N].Bits[I] := FData[Parent2].Bits[I];
  BitPos := Bit - 32 * ByteCount;
  asm
    MOV CL, BitPos
    MOV EAX, -1
    SHL EAX, CL
    MOV Mask, EAX
  end;
  FData[N].Bits[ByteCount] :=
    (FData[Parent1].Bits[ByteCount] and not Mask) or
    (FData[Parent2].Bits[ByteCount] and Mask);
end;

procedure TGeneAlgorithm.DoInversion(N: Integer);

  function GetBit(Addr: Pointer; No: Integer): Byte; assembler;
  asm
  MOV EAX, Addr
  MOV ECX, No
  BT [EAX], ECX
  SBB EAX, EAX
  AND EAX, 1
  end;

  procedure SetBit(Addr: Pointer; No: Integer; Value: Byte); assembler;
  asm
  MOV EAX, Addr
  OR Value,Value
  JZ @@1
  BTS [EAX], No
  RET
@@1:
  BTR [EAX], No
  RET
  end;

var
  Parent, Bit, I: Integer;
  B: Byte;

begin
  Parent := Random(FMinPopulation);
  Bit := Random(FDimCount * FBitPerNumber - 1);
  FData[N].Bits := FData[Parent].Bits;
  repeat
    B := GetBit(FData[N].Bits, 0);
    for I := 0 to FDimCount * FBitPerNumber - 2 do
      SetBit(FData[N].Bits, I, GetBit(FData[N].Bits, I + 1));
    SetBit(FData[N].Bits, FDimCount * FBitPerNumber - 1, B);
    if Bit = 0 then
      Break;
    Bit := Bit - 1;
  until False;
end;

procedure TGeneAlgorithm.DoMutation(N: Integer);
var
  Parent: Integer;
  Bit, BitPos, ByteCount: Integer;
  Mask: Cardinal;
begin
  Parent := Random(FMinPopulation);
  Bit := Random(FDimCount * FBitPerNumber);
  ByteCount := Bit div 32;
  BitPos := Bit - 32 * ByteCount;
  Mask := 1 shl BitPos;
  FData[N].Bits := FData[Parent].Bits;
  FData[N].Bits[ByteCount] := FData[N].Bits[ByteCount] xor Mask;
end;

procedure TGeneAlgorithm.EstimatePopulation(StartIndex: Integer);
var
  I, J, K, Index: Integer;
  P, Q, Y: Extended;
  MaxWeight, Weight: Extended;
  Addr: Pointer;
  GrayBit, BinBit: Cardinal;
begin
  MaxWeight := Power(2, FBitPerNumber);
  for I := StartIndex to Length(FData) - 1 do
  begin
    Index := 0;
    Addr := FData[I].Bits;
    for J := 0 to FDimCount - 1 do
    begin
      Weight := 0.5 * MaxWeight;
      P := 0.0;
      BinBit := 0;

      for K := 0 to FBitPerNumber - 1 do
      begin
        asm
          MOV EAX, Addr
          MOV ECX, Index
          BT [EAX], ECX
          SBB EAX, EAX
          AND EAX, 1
          MOV GrayBit, EAX
          INC Index
        end;
        BinBit := BinBit xor GrayBit;
        if BinBit = 1 then
          P := P + Weight;
        Weight := 0.5 * Weight;
      end;

      P := P / MaxWeight;
      Q := 1 - P;
      FData[I].Values[J] := P * FHighValues[J] + Q * FLowValues[J];
    end;
    Y := 0;
    FOnEstimate(Self, FData[I].Values, Y);
    FData[I].Estimate := Y;
  end;
end;

function TGeneAlgorithm.GetBestEstimate: Extended;
begin
  Lock;
  try
    Result := 0.0; //Kill warning
    if FState = gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['BestEstimate',
        SState[FState]]);
    Result := FData[0].Estimate;
  finally
    Unlock;
  end;
end;

function TGeneAlgorithm.GetBestX(I: Integer): Extended;
begin
  Lock;
  try
    Result := 0.0; // Kill warning
    if FState = gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['BestX', SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['BestX', I]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['BestX', I, 0, DimCount]);
    Result := FData[0].Values[I];
  finally
    Unlock;
  end;
end;

function TGeneAlgorithm.GetHighValues(I: Integer): Extended;
begin
  Lock;
  try
    Result := 0.0; // Kill warning
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['HighValues',
        SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['HighValues', I]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['HighValues', I, 0, DimCount]);
    Result := FHighValues[I];
  finally
    Unlock;
  end;
end;

function TGeneAlgorithm.GetIteration: Integer;
begin
  Lock;
  try
    Result := 0; // Kill warning
    if FState = gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['Iteration',
        SState[FState]]);
    Result := FIteration;
  finally
    Unlock;
  end;
end;

function TGeneAlgorithm.GetLowValues(I: Integer): Extended;
begin
  Lock;
  try
    Result := 0.0; // Kill warning
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['LowValues',
        SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['LowValues', I]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['LowValues', I, 0, DimCount]);
    Result := FLowValues[I];
  finally
    Unlock;
  end;
end;

function TGeneAlgorithm.GetState: TGeneState;
begin
  Lock;
  try
    Result := FState;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.LoadFromStream(S: TStream);
begin

end;

procedure TGeneAlgorithm.Lock;
begin
  EnterCriticalSection(FLock);
end;

procedure TGeneAlgorithm.MakeChild;
var
  I: Integer;
  RandomValue: Extended;
begin
  for I := FMinPopulation to FMaxPopulation - 1 do
  begin
    RandomValue := Random;
    if RandomValue < FCrossover then
      DoCrossover(I)
    else if RandomValue < FCrossover + FMutation then
      DoMutation(I)
    else
      DoInversion(I);
  end;
end;

procedure TGeneAlgorithm.Resume;
begin
  if FState <> gsSuspend then
    raise EGeneError.Create('Прежде чем возобновить, надо начать!');
  FSolutionThread.Create(Self);
  FState := gsExecute;
end;

procedure TGeneAlgorithm.Run;
var
  I, J: Integer;
  b1, b2: Cardinal;
begin
  Lock;
  try
    if not Assigned(FOnEstimate) then
      raise EGeneError.Create(SNonEstimate);
    Abort;

    try

      // Getting memory
      SetLength(FData, FMaxPopulation);
      for I := 0 to Length(FData) - 1 do
      begin
        FData[I].Values := nil;
        FData[I].bits := nil;
      end;
      BitSize := FDimCount * FBitPerNumber + 31;
      BitSize := BitSize and not 31;
      BitSize := BitSize div 32;
      for I := 0 to Length(FData) - 1 do
      begin
        SetLength(FData[I].Values, DimCount);
        SetLength(FData[I].Bits, BitSize);
      end;

      // Initializing Population
      for I := 0 to Length(FData) - 1 do
      begin
        for J := 0 to BitSize - 1 do
        begin
          b1 := Random(35536);
          b2 := Random(35536);
          FData[I].Bits[J] := b1 shl 16 + b2;
        end;
      end;

      EstimatePopulation(0);
      SortPopulation;
      FIteration := 0;
      FState := gsExecute;
      FSolutionThread := TSolutionThread.Create(Self);

    except

      Abort;

    end;

  finally
    Unlock;
  end;

end;

procedure TGeneAlgorithm.SaveToStream(S: TStream);
begin

end;

procedure TGeneAlgorithm.SetBitPerNumber(const Value: Integer);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['BitPerNumber',
        SState[FState]]);
    if Value <= 0 then
      raise EGeneError.CreateFmt(SInvalidParam, ['BitPerNumber', SNonPositive,
        Value]);
    FBitPerNumber := Value;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetCrossover(const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['Crossover',
        SState[FState]]);
    if (Value < 0) or (Value > 1) then
      raise EGeneError.CreateFmt(SInvalidProbality, ['кроссовера', Value]);
    FCrossover := Value;
    if FCrossover + FMutation > 1.0 then
    begin
      FMutation := 1.0 - FCrossover;
      FInversion := 0.0;
    end
    else
    begin
      FInversion := 1.0 - FMutation - FCrossover;
    end;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetDimCount(const Value: Integer);
var
  I: Integer;
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['DimCount', SState[FState]]);
    if FDimCount = Value then
      Exit;
    if Value <= 0 then
      raise EGeneError.CreateFmt(SInvalidParam, ['DimCount', SNonPositive,
        Value]);
    SetLength(FLowValues, Value);
    SetLength(FHighValues, Value);
    for I := FDimCount to Value - 1 do
    begin
      FLowValues[I] := 0.0;
      FHighValues[I] := 1.0;
    end;
    FDimCount := Value;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetHighValues(I: Integer; const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['HighValues',
        SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['HighValues', Value]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['HighValues', Value, 0,
        DimCount]);
    FHighValues[I] := Value;
    if FLowValues[I] > FHighValues[I] then
      FLowValues[I] := FHighValues[I];
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetInversion(const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['Crossover',
        SState[FState]]);
    if (Value < 0) or (Value > 1) then
      raise EGeneError.CreateFmt(SInvalidProbality, ['инверсии', Value]);
    FInversion := Value;
    if FCrossover + FInversion > 1.0 then
    begin
      FCrossover := 1.0 - FInversion;
      FMutation := 0.0;
    end
    else
    begin
      FMutation := 1.0 - FInversion - FCrossover;
    end;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetLowValues(I: Integer; const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['LowValues',
        SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['LowValues', Value]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['LowValues', Value, 0,
        DimCount]);
    FLowValues[I] := Value;
    if FHighValues[I] < FLowValues[I] then
      FHighValues[I] := FLowValues[I];
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetMaxPopulation(const Value: Integer);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['MaxPopulation',
        SState[FState]]);
    if Value < 2 then
      raise EGeneError.CreateFmt(SInvalidParam, ['MaxPopulation', SLess2,
        Value]);
    FMaxPopulation := Value;
    if FMinPopulation >= FMaxPopulation then
      FMinPopulation := FMaxPopulation - 1;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetMinPopulation(const Value: Integer);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['MinPopulation',
        SState[FState]]);
    if Value <= 0 then
      raise EGeneError.CreateFmt(SInvalidParam, ['MinPopulation', SNonPositive,
        Value]);
    FMinPopulation := Value;
    if FMinPopulation >= FMaxPopulation then
      FMaxPopulation := FMinPopulation + 1;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetMutation(const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['Crossover',
        SState[FState]]);
    if (Value < 0) or (Value > 1) then
      raise EGeneError.CreateFmt(SInvalidProbality, ['мутации', Value]);
    FMutation := Value;
    if FCrossover + FMutation > 1.0 then
    begin
      FCrossover := 1.0 - FMutation;
      FInversion := 0.0;
    end
    else
    begin
      FInversion := 1.0 - FMutation - FCrossover;
    end;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetOnBestChange(const Value: TBestChangeEvent);
begin
  Lock;
  try
    FOnBestChange := Value;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetOnEstimate(const Value: TEstimateEvent);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['OnEstimate',
        SState[FState]]);
    FOnEstimate := Value;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SetOnIteration(const Value: TIterationEvent);
begin
  Lock;
  try
    FOnIteration := Value;
  finally
    Unlock;
  end;
end;

procedure TGeneAlgorithm.SortPopulation;

  procedure QuickSort(L, R: Integer);
  var
    I, J: Integer;
    P: Extended;
    T: TGeneRecord;
  begin
    repeat
      I := L;
      J := R;
      P := FData[(L + R) shr 1].Estimate;
      repeat
        while FData[I].Estimate > P do
          Inc(I);
        while FData[J].Estimate < P do
          Dec(J);
        if I <= J then
        begin
          if (I = 0) or (J = 0) then
            Lock;
          try
            T := FData[I];
            FData[I] := FData[J];
            FData[J] := T;
          finally
            if (I = 0) or (J = 0) then
              UnLock;
          end;
          Inc(I);
          Dec(J);
        end;
      until I > J;
      if L < J then
        QuickSort(L, J);
      L := I;
    until I >= R;
  end;

begin
  QuickSort(0, Length(FData) - 1);
end;

procedure TGeneAlgorithm.Suspend;
begin
  if FState <> gsExecute then
    raise EGeneError.Create('Прежде чем остановить, надо запустить!');
  FSolutionThread.Terminate;
  // FSolutionThread.WaitFor;
  FState := gsSuspend;
end;

procedure TGeneAlgorithm.Unlock;
begin
  LeaveCriticalSection(FLock);
end;

{ TSolutionThread }

constructor TSolutionThread.Create(AOwner: TGeneAlgorithm);
begin
  FOwner := AOwner;
  FreeOnTerminate := True;
  inherited Create(False);
end;

procedure TSolutionThread.Execute;
begin
  repeat
    Owner.MakeChild;
    Owner.EstimatePopulation(Owner.FMinPopulation);
    Owner.SortPopulation;
    Inc(Owner.FIteration);
  until Terminated;
  Sleep(10);
end;

end.

Пример использования:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Genes, ExtCtrls, Grids;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Edit4: TEdit;
    Button4: TButton;
    Button5: TButton;
    Timer1: TTimer;
    Button7: TButton;
    Label1: TLabel;
    Grid: TStringGrid;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    procedure Refresh;
    procedure GeneEstimate(Sender: TObject; const X: TExtendedArray; var Y:
      Extended);
  public
    FGene: TGeneAlgorithm;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  DecimalSeparator := '.';
  FGene := TGeneAlgorithm.Create;
  Refresh;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FGene.Free;
end;

procedure TForm1.Refresh;
begin
  Edit1.Text := FloaTtoStr(FGene.Crossover);
  Edit2.Text := FloatToStr(FGene.Mutation);
  Edit3.Text := FloatToStr(FGene.Inversion);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FGene.Crossover := StrTofloat(Edit1.Text);
  Refresh;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  FGene.Mutation := StrTofloat(Edit2.Text);
  Refresh;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  FGene.Inversion := StrTofloat(Edit3.Text);
  Refresh;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  FGene.BitPerNumber := StrToInt(Edit4.Text);
  Edit4.Text := IntToStr(FGene.BitPerNumber);
end;

procedure TForm1.Button5Click(Sender: TObject);
var
  I: Integer;
begin
  Randomize;
  FGene.DimCount := 5;
  FGene.MaxPopulation := 10000;
  FGene.MinPopulation := 5000;
  FGene.OnEstimate := GeneEstimate;
  for I := 0 to 4 do
  begin
    FGene.LowValues[I] := 0;
    FGene.HighValues[I] := 10;
  end;
  FGene.Run;
  Timer1.Enabled := True;
end;

procedure TForm1.GeneEstimate(Sender: TObject; const X: TExtendedArray;
  var Y: Extended);
var
  I: Integer;
begin
  Y := 0;
  for I := Low(X) to High(X) do
    Y := Y + Sqr(X[I] - I);
  Y := -Y;
end;

procedure TForm1.Button7Click(Sender: TObject);
var
  I: Integer;
begin
  Timer1.Enabled := False;
  Label1.Caption := '';
  FGene.Suspend;
  Grid.RowCount := FGene.DimCount + 1;
  for I := 0 to FGene.DimCount - 1 do
    Grid.Cells[0, I + 1] := FloattoStr(FGene.BestX[I]);
  FGene.Abort;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Label1.Caption := FloatToStr(FGene.BestEstimate);
end;

end.