Генетические алгоритмы

Генетические алгоритмы

{ **** UBPFD *********** by kladovka.net.ru ****
>>
Класс, реализующий генетический алгоритм.
Зависимости: Classes, SysUtils, Windows, Math
Автор: Mystic, <a href="mailto:mystic2000@newmail.ru">mystic2000@newmail.ru</a>, 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.

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...