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

program gen_alg;
uses crt;
 
const maxpop = 100;
maxstring = 30;
dim = 2; {размерность пространства поиска: х и y}
 
type allele = boolean; {Алель  позиция в битовой строке} 
chromosome =array [1..maxstring*dim] of allele; {Хромосома – битовая строка}
fenotype=array[1..dim] of real;
 
individual=record
  chrome: chromosome; {генотип – битовая строка}
  x: fenotype; {фенотип – координаты точки в пространстве поиска}
  fitness: real; {значение целевой функции}
  end;
 
population = array [1..maxpop] of individual;
 
const xmax: fenotype=(5.12,5.12); {массив максимальных значений для координат точки в пространстве поиска}
xmin: fenotype = (-5.12,-5.12); {массив минимальных значений для координат точки в пространстве поиска}
 
 
var oldpop, newpop, intpop: population; {Три непересекающихся популяции  старая, новая и промежуточная}
popsize,lchrom,ncross,nmutation,maxgen,gen: integer;
pcross,pmutation: real; {вероятность скрещивания и мутации }
min,max,avg,sumfitness:real; {статистическая информация}
 
{целевая функция z=int(x)+int(y)}
function objfunc(x:fenotype): real;
  begin
  objfunc:=int(x[2])+int(x[2]);
  end;
 
{функция с вероятностью probability возвращает значение true}
function flip(probability:real):boolean;
  begin
  flip:=(probability=1.0) or (random<=probability);
  end;
 
{процедура декодирования битовой строки – генотипа – в вещественные числа – фенотип. True = 1, False=0}
procedure decode(chrom: chromosome; lbits: integer; var x: fenotype);
  var i,j: integer;
  f, accum, powerof2: real;
  begin
    for i:=1 to dim do
      begin
      accum:=0.0;
      powerof2:=1;
      f:=1;
      for j:=1+lbits*(i-1) to lbits*i do
        begin
        if chrom[j] then
          accum:=accum+powerof2;
        powerof2:=powerof2*2;
        f:=f*2;
        end;
        x[i]:=xmin[i]+(xmax[i]-xmin[i])*accum/(f-1);
      end;
  end;
 
{Инициализация начальной популяции случайным образом} 
procedure initpop;
  var j,j1: integer;
  begin
    for j:=1 to popsize do
      with oldpop[j] do
        begin
        for j1:=1 to lchrom*dim do
          chrome[j1]:=flip(0.5);
          decode(chrome,lchrom,x);
          fitness:=objfunc(x);
        end;
  end;
 
{генетические операторы}
{отбор}
procedure select;
  var ipick: integer;
 
{перемешивание популяции в ходе отбора}
  procedure shuffle(var pop: population);
    var i,j: integer;
    ind0: individual;
 
    begin
    for i:=popsize downto 2 do
      begin
      j:=random(i-1)+1;
      ind0:=pop[i];
      pop[i]:=pop[j];
      pop[j]:=ind0;
      end;
    end;
 
  function select1: integer;
    var j1,j2,m: integer;
    begin
    if ipick>popsize then
      begin
      shuffle(oldpop);
      ipick:=1;
      end;
    j1:=ipick;
    j2:=ipick+1;
    if (oldpop[j2].fitness<oldpop[j1].fitness) then
      m:=j2
    else
      m:=j1;
    ipick:=ipick+2;
    select1:=m;
    end;
 
  var j: integer;
 
  begin
  ipick:=1;
    for j:=1 to popsize do
      intpop[j]:=oldpop[select1];
    oldpop:=intpop;
  end;
 
{мутация}
{мутация хромосомы val с вероятностью pmutation}
{мутация двухточечная, т.е. выбираются две аллели, значения которых обмениваются}
procedure mutation(var val:chromosome; const flchrom: integer;
                  pmutation: real; var nmutation:integer);
 
  var mutate: boolean;
  point1,point2:integer;
  buf: allele;
  begin
  mutate:=flip(pmutation);
  if mutate then
    begin
    inc(nmutation);
    point1:=random(flchrom-1)+1;
    point2:=random(flchrom-1)+1;
    buf:=val[point1];
    val[point1]:=val[point2];
    val[point2]:=buf;
    end;
  end;
 
{двухточечное скрещивание}
{Скрещивание 2 родительских строк, результат помещается в 2 строках-потомках} 
 
procedure crossover(var parent1, parent2, child1, child2: chromosome;
          flchrom:integer; var ncross,nmutation:integer;
          var pcross,pmutation: real);
  var j: integer;
  point1,point2,buf: integer;
  begin
  if flip(pcross) then {если скрещивание должно произойти}
    begin
    inc(ncross);
    {выбираем точки скрещивания}
    point1:=random(flchrom-1)+1;
    point2:=random(flchrom-1)+1;
 
    if point1>point2 then {вторая точка должна идти после первой}
      begin
      buf:=point1;
      point1:=point2;
      point2:=buf;
      end;
    end
  else  {если скрещивание не происходит}
    begin
    point1:=flchrom;
    point2:=flchrom;
    end;
 
  for j:=1 to point1 do
    begin
    child1[j]:=parent1[j];
    child2[j]:=parent2[j];
    end;
 
  for j:=point1+1 to point2 do
    begin
    child1[j]:=parent2[j];
    child2[j]:=parent1[j];
    end;
 
  for j:=point2+1 to flchrom do
    begin
    child1[j]:=parent1[j];
    child2[j]:=parent2[j];
    end;
 
  mutation(child1,flchrom,pmutation,nmutation);
  mutation(child1,flchrom,pmutation,nmutation);
  end;
 
{Генерирование нового поколения при помощи отбора, скрещивания и мутации} 
{Прим: предполагается, что популяция имеет четный размер} 
procedure generation;
  var j, mate1, mate2: integer;
 
  begin
  select;
  j:=1;
{выполняются отбор, скрещивание и мутация, пока полностью не сформируется новая популяция  newpop} 
  repeat;
    {выбор родительской пары}
    mate1:=j; 
    mate2:=j+1;
    {срещивание и мутация (мутация встроена в процедуру скрещивания}
    crossover(oldpop[mate1].chrome, oldpop[mate2].chrome,
              newpop[j].chrome, newpop[j+1].chrome,
              lchrom*dim, ncross, nmutation, pcross, pmutation);
    with newpop[j] do
      begin
     {декодирование}
      decode(chrome,lchrom,x);
      {вычисление пригодности с помощью весовой функции}
      fitness:=objfunc(x);
      end;
    j:=j+1;
  until j>popsize;
  end;
 
{процедура подсчета статистических данных}
procedure statistics(popsize: integer; var max,avg,min,sumfitness: real;
                     var pop: population; var xmin,ymin: real);
  var j: integer;
 
  begin
  sumfitness:=pop[1].fitness;
  min:=pop[1].fitness;
  max:=pop[1].fitness;
  xmin:=pop[1].x[1];
  ymin:=pop[1].x[2];
  for j:=2 to popsize do
    with pop[j] do
      begin
      sumfitness:=sumfitness+fitness;
      if fitness>max then
        max:=fitness;
      if fitness<min then
        begin
        min:=fitness;
        xmin:=pop[j].x[1];
        ymin:=pop[j].x[2];
        end;
      end;
  avg:=sumfitness/popsize;
  end;
 
var min_,avg_,xmin_,ymin_: real;
i,cnt: integer;
 
  begin {головная программа}
  clrscr;  
  cnt:=20; {число повторений}
  min_:=MaxInt;
  avg_:=0; {глобальный средний результат}
  for i:=1 to cnt do
    begin
    popsize:=30; {размер популяции}
    lchrom:=30; { число битов на один кодируемый параметр}
    maxgen:=100; {максимальное число поколений}
    pmutation:=0.01; {вероятность мутации}
    pcross:=0.8; {вероятность скрещивания}
    {инициализация генератора случайных чисел}
    randomize;
    {инициализация счетчиков}
    nmutation:=0;
    ncross:=0;
    initpop;
    statistics(popsize,max,avg,min,sumfitness,oldpop,xmin_,ymin_);
    gen:=0;
    repeat  {главный итерационный цикл}
      gen:=gen+1;
      generation;
      statistics(popsize,max,avg,min,sumfitness,newpop,xmin_,ymin_);
      oldpop:=newpop; {переход на новое поколение}
    until (gen>=maxgen);
    writeln('min=',min:10:8,' x=',xmin_:9:7,' y=',ymin_:9:7);
    avg_:=avg_+min;
    if min_>min then
      min_:=min;
  end;
  avg_:=avg_/cnt;
  writeln('global min=',min_:10:8);
  writeln('global avg=',avg_:10:8);
  readln;
  end.