Генетические алгоритмы (стр. 4 )

fPopulation[0,xI].GeneSize := Value;

fPopulation[1,xI].GeneSize := Value;

end;

end;

function TGeneticAlgorithm. GetSelChromosome;

var

xC1,xC2 : TChromosome;

begin

// используется турнирный отбор

repeat

xC1 := fPopulation[fEpoch mod 2,Random(ChromosomeCount)];

xC2 := fPopulation[fEpoch mod 2,Random(ChromosomeCount)];

until xC1 <> xC2;

if OptimizeMethod = omMinimize then

begin

if xC1.Suitability < xC2.Suitability then Result := xC1

else Result := xC2;

end

else

begin

if xC1.Suitability > xC2.Suitability then Result := xC1

else Result := xC2;

end;

// а здесь попытаемся реализовать метод "рулетки"

end;

function TGeneticAlgorithm. GetChromosome(Index : integer) : TChromosome;

begin

if Index >= fChromosomeCount then

raise Exception. Create('Chromosome index out of bounds');

Result := fPopulation[fEpoch mod 2,Index];

end;

procedure TGeneticAlgorithm. SetChromosomeCount(Value : integer);

var

xI : integer;

begin

if (Value <= 0) or (Value > MAX_CHROMOSOME_PER_POPULATION) then

raise Exception. Create('Number of chromosome out of bounds');

// инициализируем популяции

for xI := 0 to fChromosomeCount-1 do

begin

fPopulation[0,xI].Free;

fPopulation[1,xI].Free;

end;

fChromosomeCount := Value;

fPopulation[0] := nil;

fPopulation[1] := nil;

SetLength(fPopulation[0],fChromosomeCount);

SetLength(fPopulation[1],fChromosomeCount);

for xI := 0 to fChromosomeCount-1 do

begin

fPopulation[0,xI] := TChromosome. Create;

fPopulation[1,xI] := TChromosome. Create;

if GeneCount > 0 then

begin

fPopulation[0,xI].GeneCount := GeneCount;

fPopulation[1,xI].GeneCount := GeneCount;

end;

if GeneSize > 0 then

begin

fPopulation[0,xI].GeneSize := GeneSize;

fPopulation[1,xI].GeneSize := GeneSize;

end;

end;

end;

// один шаг формирования алгоритма

procedure TGeneticAlgorithm. OneEpoch;

var

xI : integer;

xS : double;

xV : double;

xChromosome1,

xChromosome2,

xChromosome3 : TChromosome;

begin

// вычисляем приспособленность эпохи

if not Assigned(fGetSutability) then

raise Exception. Create('OnGetSutability must be assigned');

fSutability := 0;

for xI := 0 to ChromosomeCount-1 do

begin

xChromosome1 := fPopulation[fEpoch mod 2,xI];

xS := fGetSutability(xChromosome1);

xChromosome1.Suitability := xS;

// устанавливаем параметры для запуска "рулетки"

if xI = 0 then

begin

fMinSutability := xS;

fMaxSutability := xS;

end;

if xS <= fMinSutability then

begin

fMinSutability := xS;

if OptimizeMethod = omMinimize then

fBestChromosome := xChromosome1;

end;

if xS >= fMaxSutability then

begin

fMaxSutability := xS;

if OptimizeMethod = omMaximize then

fBestChromosome := xChromosome1;

end;

// пересчитываем приспособленность выборки

fSutability := fSutability + xChromosome1.Suitability;

end;

// а теперь формируем следующее поколение

if UseElita then

begin

Clone(fBestChromosome, fPopulation[(fEpoch + 1) mod 2,0]);

end;

for xI := integer(UseElita) to fChromosomeCount-1 do

begin

xChromosome3 := fPopulation[(fEpoch + 1) mod 2,xI];

// берем хромосому из текущей выборки

xChromosome1 := GetSelChromosome;

// смотрим, что будем с ней делать

Clone(xChromosome1,xChromosome3);

xV := Random;

// если надо, то скрещиваем

if xV < CROSSOVER_P then

begin

repeat

xChromosome2 := GetSelChromosome;

until xChromosome1<>xChromosome2;

Crossover(xChromosome1,xChromosome2,xChromosome3);

end;

xV := Random;

if xV < MUTATION_P then

begin

Mutation(xChromosome3,xChromosome3);

continue;

end;

xV := Random;

if xV < INVERSION_P then

begin

Inversion(xChromosome3,xChromosome3);

continue;

end;

end;

inc(fEpoch);

end;

// внутреннее - декодирование в ген

function DecodeGene(Vector : TBits{Vector};StartPos, Length : integer) : LongWord;

var

xI, xJ : integer;

xVal : byte;

xMask : byte;

xTCount : integer; //количество тетрад

begin

Result := 0;

// выделяем тетрады

xTCount := Length shr 2;

// собираем потетрадно

for xI := 0 to xTCount-1 do

begin

// читаем тетраду

xVal := 0;

xMask := 8;

for xJ := 0 to 3 do

begin

if Vector[StartPos + xI*4 + xJ] then

xVal := xVal + xMask;

xMask := xMask shr 1;

end;

// декодируем

Result := Result shl 4;

// декодируем тетраду

Result := Result or GrayToDec[xVal];

end;

end;

// и, для разнообразия, кодирование в ген

procedure EncodeGene(var Vector: TBits; StartPos, Length: integer; Value: LongWord);

var

xI, xJ : integer;

xVal : byte;

xMask : byte;

xTCount : integer; //количество тетрад

begin

// выделяем тетрады

xTCount := Length shr 2;

// собираем потетрадно

for xI := xTCount-1 downto 0 do

begin

// кодируем тетраду

xVal := DecToGray[Value and 15];

Value := Value shr 4;

// читаем тетраду

xMask := 1;

for xJ := 3 downto 0 do

begin

Vector[StartPos + xI*4 + xJ] := (xVal and xMask) > 0;

xMask := xMask shl 1;

end;

end;

end;

procedure Crossover(Src1, Src2: TChromosome; var Result: TChromosome);

var

xPos : integer;

I: integer;

begin

// определяем точку кроссовера

xPos := Random(Src1.Size - 2) + 2;

for I := 0 to xPos - 1 do

Result. Bits[I] := Src1.Bits[I];

for I := xPos to Src1.Size - 1 do

Result. Bits[I] := Src2.Bits[I];

end;

procedure Mutation(Src:TChromosome;var Result : TChromosome);

var

xI : integer;

begin

for xI := 0 to Src. Size - 1 do

begin

if Random < 0.1 then

Result[xI] := not Src[xI]

else

Result[xI] := Src[xI];

end;

end;

procedure Clone(Src:TChromosome;var Result : TChromosome);

var

xI: integer;

begin

for xI := 0 to Src. Size - 1 do

Result[xI] := Src[xI];

end;

procedure Inversion(Src: TChromosome; var Result : TChromosome);

var

xPos, I: integer;

begin

// находим точку инверсии

xPos := Random(Src. Size - 2) + 2;

for I := xPos to Src. Size - 1 do

Result[I - xPos] := Src[I];

for I := 0 to xPos - 1 do

Result[I + Src. Size - xPos] := Src[I];

end;

procedure TGeneticAlgorithm. SetGeneDegree(Value: TGeneDegree);

begin

fGeneDegree := Value;

case Value of

Short_8 : GeneSize := 8;

Midle_16 : GeneSize := 16;

Long_32 : GeneSize := 32;

end;

Init; end;

procedure TGeneticAlgorithm. SetCrossever(const Value: double);

begin

fCrossover := Value;

end;

procedure TGeneticAlgorithm. SetInversion(Value: double);

begin

fInversion := Value;

end;

procedure TGeneticAlgorithm. SetMutation(Value: double);

begin

fMutation := Value;

end;

procedure TChromosome. Assign(Source: TChromosome);

var

xSrc: TChromosome;

I: integer;

begin

inherited;

// Переписываем гены

xSrc := Source as TChromosome;

fDegree := xSrc. fDegree;

fGeneCount := xSrc. fGeneCount;

SetLength(fGene, fGeneCount);

for I := 0 to fGeneCount - 1 do

fGene[I] := xSrc. fGene[I];

end;

procedure TGeneticAlgorithm. Assign(Source: TPersistent);

var

xSrc: TGeneticAlgorithm;

I: integer;

xC: TChromosome;

begin

// inherited;

xSrc := Source as TGeneticAlgorithm;

ChromosomeCount := xSrc. fChromosomeCount;

GeneSize := xSrc. GeneSize;

GeneCount := xSrc. GeneCount;

Crossover_P := xSrc. Crossover_P;

Inversion_P := xSrc. Inversion_P;

Mutation_P := xSrc. Mutation_P;

OnGetSutability := xSrc. OnGetSutability;

OptimizeMethod := xSrc. OptimizeMethod;

UseElita := xSrc. UseElita;

Epoch := xSrc. Epoch;

// переписываем хромосомы

for I := 0 to ChromosomeCount - 1 do

begin

xC := xSrc. fPopulation[0, I];

fPopulation[0, I].Assign(xC);

if xC = xSrc. fBestChromosome then

fBestChromosome := xC;

xC := xSrc. fPopulation[1, I];

fPopulation[1, I].Assign(xC);

if xC = xSrc. fBestChromosome then

fBestChromosome := xC;

end;

end;

function Copy(Src : TBits; Index, Counter : integer):TBits;

var

xLen: integer;

I: integer;

begin

Result := nil;

if Index > Src. Size then

Exit;

// создаем вектор - приемник

Result := TBits. Create;

xLen := min(Counter, Src. Size - Index);

// определяем его длинну

Result. Size := xLen;

for I := 0 to xLen - 1 do

Result. Bits[I] := Src. Bits[I];

end;

function Concat(Src1,Src2 : TBits) : TBits;

var

I, xLen: integer;

begin

Result := TBits. Create;

xLen := Src1.Size + Src2.Size;

Result. Size := xLen;

for I := 0 to pred(Src1.Size) do

Result. Bits[I] := Src1.Bits[I];

for I := Src1.Size to pred(xLen) do

Result. Bits[I] := Src2[I - Src1.Size];

end;

// удаление подстроки

function Delete(Src: TBits; Index, Counter: integer):TBits;

begin

Result := nil;

if Index > Src. Size then exit;

Result := Concat(Copy(Src, 0, Index), Copy(Src, Index+Counter, Src. Size));

end;

procedure Register;

begin

RegisterComponents('GeneBase',[TGeneticAlgorithm]);

end;

end.