unit genetic;

interface
uses Classes,{NewBitMath,}SysUtils, Math;

const
  // таблицы преобразования для кода Грея
  GrayToDec : array[0..15] of byte = (0,1,3,2,7,6,4,5,15,14,12,13,8,9,11,10);
  DecToGray : array[0..15] of byte = (0,1,3,2,6,7,5,4,12,13,15,14,10,11,9,8);

  // параметры алгоритма по умолчанию
  DEFAULT_GENE_DEGREE = 32;
  DEFAULT_GENE_COUNT  = 2;
  MAX_GENE_COUNT      = 1024;
  MAX_CHROMOSOME_PER_POPULATION = 10000;
  CROSSOVER_PROBABILITY = 0.98;
  MUTATION_PROBABILITY = 0.1;
  SHIFT_PROBABILITY = 0.2;
  INVERSION_PROBABILITY = 0.1;


type
  TGene = record
    BegPos   : integer;   // положение первого элемента гена в хромосоме
    Degree   : integer;   // длинна гена
  end;

  TGeneDegree = (Short_8,Midle_16,Long_32);
  
  TOptimizeMethod = (omMinimize,omMaximize);

  // основной класс - хромосома
  TChromosome = class(TBits{Vector})
  private
    fDegree    : integer;   // длинна гена
    fGeneCount : integer;   //количество генов
    fGene : array of TGene; //Массив описателей генов
    procedure SetGeneCount(Value : integer);
    function  GetGeneSize:integer;
    procedure SetGeneSize(Value:integer);
    function  GetGene(Index:integer):LongWord;
    procedure SetGene(Index:integer;Value:LongWord);
    function  GetGeneAsInteger(Index:integer):LongInt;
    procedure SetGeneAsInteger(Index:integer;Value:LongInt);
    function  GetGeneAsFloat(Index:integer):double;
    procedure SetGeneAsFloat(Index:integer;Value:double);
  public
    Suitability : double;
    constructor Create;
    destructor Destroy;override;
//    procedure Assign(Source: TPersistent); virtual;//override;
    procedure Assign(Source: TChromosome);// virtual;//override;
    property GeneCount : integer read fGeneCount write SetGeneCount;
    property GeneSize : Integer read GetGeneSize write SetGeneSize;
    property GeneValue[Index:integer] : Longword read GetGene write SetGene;//default;
    property GeneAsInteger[Index:integer] : LongInt read GetGeneAsInteger write SetGeneAsInteger;
    property GeneAsFloat[Index:integer] : double read GetGeneAsFloat write SetGeneAsFloat;
  end;

  // а теперь собственно генетический алгоритм
  // Call-Back функция для вычисления приспособленности особи
  TGetSutability = function(Chromosome : TChromosome) : double of object;
  TGeneticAlgorithm = class(TComponent)
  private
    // это у нас будет популяция
    fPopulation : array [0..1] of array of TChromosome;
    fEpoch      : integer;      // номер текущей эпохи алгоритма
    fSutability : double;       // приспособленность текущей эпохи
    fChromosomeCount : integer; // количество хромосом в популяции
    fGeneCount : integer;       //количество генов
    fMinSutability : double;
    fMaxSutability : double;
    fGetSutability : TGetSutability;  // процедура оценки приспособленности
//    fCurPopulations   : TList;
    fUseElita: boolean;
    fBestChromosome : TChromosome;
    fGeneDegree : TGeneDegree;
    fOptimizeMethod : TOptimizeMethod;
    fGeneSize       : integer;
    fInversion      : double;
    fCrossover      : double;
    fMutation       : double;
    // получение хромосомы из текущего поколения с использованием "рулетки"
    function  GetSelChromosome : TChromosome;
    procedure SetChromosomeCount(Value : integer);
    function  GetChromosome(Index:integer):TChromosome;
    procedure SetGeneCount(Value : integer);
    procedure SetGeneSize(Value:integer);
//    function  GetGeneSize:integer;
    procedure SetGeneDegree(Value : TGeneDegree);
    procedure SetMutation(Value : double);
    procedure SetInversion(Value : double);
    procedure SetCrossever(const Value: double);
  public
    constructor Create(AOwner : TComponent);override;
    destructor  Destroy;override;
    procedure Init;
    procedure OneEpoch;
    procedure Assign(Source: TPersistent); override;    
    property BestChromosome : TChromosome read fBestChromosome;
    property Epoch : integer read fEpoch write fEpoch;
    property Suitability : double read fSutability;
    property Chromosome[Index:integer] : TChromosome read GetChromosome;default;
    property GeneSize : integer read fGeneSize write SetGeneSize;
  published
    property UseElita : boolean read fUseElita write fUseElita;
    property OnGetSutability : TGetSutability read fGetSutability write fGetSutability;
    property GeneCount : integer read fGeneCount write SetGeneCount; // количество генов в особи
    property ChromosomeCount : integer read fChromosomeCount write SetChromosomeCount; // количество особей в популяции
    property GeneDegree : TGeneDegree read fGeneDegree write SetGeneDegree;
    property OptimizeMethod : TOptimizeMethod read fOptimizeMethod write fOptimizeMethod;
    property Mutation_P  : double read fMutation write SetMutation;
    property Inversion_P : double read fInversion write SetInversion;
    property Crossover_P : double read fCrossover write SetCrossever;
  end;

function DecodeGene(Vector : TBits{Vector};StartPos,Length : integer) : LongWord;
procedure EncodeGene(var Vector: TBits; StartPos, Length: integer; Value: LongWord);

procedure Clone(Src:TChromosome;var Result : TChromosome);
procedure Crossover(Src1,Src2 : TChromosome; var Result : TChromosome);
procedure Mutation(Src:TChromosome;var Result : TChromosome);
procedure Inversion(Src:TChromosome;var Result : TChromosome);

// список основных опреация для работы с битовыми строками
function Copy(Src : TBits; Index,Counter : integer):TBits;
function Concat(Src1,Src2 : TBits) : TBits;
function Delete(Src : TBits; Index,Counter : integer):TBits;

procedure Register;

implementation
{$R *.dcr}
// работа с классом
constructor TChromosome.Create;
begin
  inherited;
  GeneCount := DEFAULT_GENE_COUNT;
end;
destructor TChromosome.Destroy;
begin
  fGene := nil;
  inherited;
end;
procedure TChromosome.SetGeneCount(Value : integer);
var
  xI : integer;
begin
  if (Value<1) or (Value>MAX_GENE_COUNT) then
    raise Exception.Create('Gene count out of bounds');
  SetLength(fGene,Value);
  // проверяем, что нам надо сделать по умолчанию
  if Value > fGeneCount then
    for xI := fGeneCount to Value-1 do
      fGene[xI].Degree := DEFAULT_GENE_DEGREE;
  fGeneCount := Value;
  // пересчитываем массив генов
  GeneSize := GeneSize;
end;
procedure TChromosome.SetGeneSize(Value:integer);
var
  xI   : integer;
  xLen : integer;
begin
  // пересчитываем индексы гена
  xLen := 0;
  fDegree := Value;
  for xI := 0 to fGeneCount-1 do
  begin
    fGene[xI].Degree := Value;
    fGene[xI].BegPos := xLen;
    xLen := xLen + fGene[xI].Degree;
  end;
  // устанавливаем размерность битового вектора хромосомы
//  Length := xLen;
  Size := xLen;
end;

// установка длины гена
function TChromosome.GetGeneSize : integer;
begin
  // проверяем, не вылетели ли мы с номером гена
  Result := fDegree;
end;

// чтение значения гена
function TChromosome.GetGene(Index:integer):LongWord;
begin
  Result := DecodeGene(Self, fGene[Index].BegPos, fGene[Index].Degree);
end;

// установка значения гена
procedure TChromosome.SetGene(Index:integer;Value:LongWord);
begin
  EncodeGene(TBits(Self), fGene[Index].BegPos, fGene[Index].Degree, Value);
end;

// чтение значения гена как целого числа
function TChromosome.GetGeneAsInteger(Index:integer):Integer;
var
  xVal : Cardinal;
begin
  // читаем значение и преобразуем его в нужный интервал
  xVal := GetGene(Index);
  case GeneSize of
    8  : Result := xVal - 128;
    16 : Result := xVal - 32768;
    32 : Result := xVal - 2147483648;
  else
    Result := xVal;
  end;
end;

procedure TChromosome.SetGeneAsInteger(Index:integer;Value:Integer);
begin
  case GeneSize of
    8  : EncodeGene(TBits(Self),fGene[Index].BegPos,fGene[Index].Degree, Value + 128);
    16 : EncodeGene(TBits(Self),fGene[Index].BegPos,fGene[Index].Degree, Value + 32768);
    32 : EncodeGene(TBits(Self),fGene[Index].BegPos,fGene[Index].Degree, Value + integer(2147483648));
  else
    EncodeGene(TBits{Vector}(Self),fGene[Index].BegPos,fGene[Index].Degree,Value);
  end;
end;
function  TChromosome.GetGeneAsFloat(Index:integer):double;
var
  xVal : LongWord;
begin
  xVal := GetGene(Index);
  case GeneSize of
    8  : Result := xVal/255;
    16 : Result := xVal/65535;
    32 : Result := xVal/4294967295;
  else
    Result := xVal;
  end;
end;
procedure TChromosome.SetGeneAsFloat(Index:integer;Value:double);
begin
  case GeneSize of
    8  : SetGene(Index,Round(Value*255));
    16 : SetGene(Index,Round(Value*65535));
    32 : SetGene(Index,Round(Value*4294967295));
  else
    EncodeGene(TBits{Vector}(Self),fGene[Index].BegPos,fGene[Index].Degree,round(Value));
  end;
end;

//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
constructor TGeneticAlgorithm.Create;
begin
  inherited;
  fEpoch          := 0;
  fSutability     := 0;
  ChromosomeCount := 1;
  // создаем массив объектов
  GeneSize        := 8;
  GeneCount       := 1;
  Init;
  Mutation_P := MUTATION_PROBABILITY;
  Inversion_P := INVERSION_PROBABILITY;
  Crossover_P := CROSSOVER_PROBABILITY;
end;

destructor TGeneticAlgorithm.Destroy;
var
  xI : integer;
begin
  for xI := 0 to fChromosomeCount-1 do
  begin
    fPopulation[0,xI].Free;
    fPopulation[1,xI].Free;
  end;
  inherited;
end;

procedure TGeneticAlgorithm.Init;
var
  xI,xJ : integer;
  xLen  : integer;
begin
  xLen := fPopulation[0,0].Size;
  for xI := 0 to fChromosomeCount-1 do
    for xJ := 0 to xLen - 1 do
    begin
      fPopulation[0,xI].Bits[xJ] := Random(2) > 0;
      fPopulation[1,xI].Bits[xJ] := Random(2) > 0;
    end;
end;

procedure TGeneticAlgorithm.SetGeneCount(Value : Integer);
var
  xI : integer;
begin
  fGeneCount := Value;
  for xI := 0 to fChromosomeCount-1 do
  begin
    fPopulation[0,xI].GeneCount := Value;
    fPopulation[1,xI].GeneCount := Value;
  end;
  Init;
end;

{function TGeneticAlgorithm.GetGeneSize : integer;
begin
  Result := fPopulation[0,0].GeneSize;
end;}

procedure TGeneticAlgorithm.SetGeneSize(Value:integer);
var
  xI : integer;
begin
  fGeneSize := Value;
  for xI := 0 to fChromosomeCount-1 do
  begin
    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 Register;
begin
  RegisterComponents('GeneBase',[TGeneticAlgorithm]);
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;

end.