Документ взят из кэша поисковой машины. Адрес оригинального документа : http://www.abitu.ru/en2002/closed/viewwork.html?ext=24 Дата изменения: Fri May 5 15:23:59 2006 Дата индексирования: Tue Oct 2 02:09:30 2012 Кодировка: Windows-1251

program kom;
{$APPTYPE CONSOLE}
uses
SysUtils;
const n_t=20; //кол-во городов
n_os=50; //кол-во особей
v_mut=1; //вероятность мутации для каждой особи(в %)
v_cross=60;//вероятность скрещивания для каждой пары особей(в %)
max=10; //максимальное расстояние между городами
type TTowns=array[1..n_t,1..n_t]of byte;
//массив, описывающий расстояния между городами
TOsobi=array[1..n_os+1,1..n_t]of byte;
//массив хромосом

var towns:TTowns;//переменная городов
i,j,k,p,n:word;//переменные для циклов и т.д. и т.п.
osobi,new_osobi,pr:TOsobi;//переменные особей
c:char;//просто символьная переменная

procedure gen_towns;
begin
for i:=1 to n_t do
begin
for k:=i+1 to n_t do
begin
towns[i,k]:=random(max)+1;
towns[k,i]:=towns[i,k];
end;
towns[i,i]:=0;
end;
end;

procedure gen_pop;
begin
for i:=1 to n_os+1 do
begin
//заполняем особь городами 1,2,3...20
for k:=1 to n_t do osobi[i,k]:=k;
{меняем местами первый ген и случайный,
затем второй и другой случайный и т.д.
В результате каждый город встретится в
хромосоме лишь один раз}
for k:=1 to n_t do
begin
j:=osobi[i,k];
p:=random(n_t)+1;
osobi[i,k]:=osobi[i,p];
osobi[i,p]:=j;
end;
end;
end;

procedure selection;
var best:byte;//номер лучшей особи
prisp:array[0..n_os+1]of word;
//массив приспособленностей особей
begin
prisp[0]:=0;
p:=200;
best:=0;
//цикл заполнения массива prisp
for i:=1 to n_os+1 do
begin
j:=0;
for k:=2 to n_t do
j:=j+towns[osobi[i,k-1],osobi[i,k]];
prisp[i]:=prisp[i-1]+10000 div j;
if p>j then begin
p:=j;
best:=i;
end;
end;
//копирование лучшей особи на (n_os+1)-е элитное место
for i:=1 to n_t do new_osobi[n_os+1,i]:=osobi[best,i];
//реализация рулетки
for i:=1 to n_os do
begin
j:=random(prisp[n_os]);
for k:=1 to n_os do
if prisp[k]>j then
begin
j:=k;
break;
end;
for k:=1 to n_t do new_osobi[i,k]:=osobi[j,k];
end;
//обмен переменных osobi и new_osobi через pr
pr:=osobi;
osobi:=new_osobi;
new_osobi:=pr;
//выводим наименьший путь для каждого 250-го поколения
//n-счетчик поколений (в основной функции)
if n mod 250=0 then writeln(p);
end;

procedure crossover;
var u:integer;
prom:array[1..n_t]of byte;
//промежуточный массив для записи генов
begin
for i:=1 to n_os div 2 do
//решаем, призводить ли скрещивание
if random(100) begin
//устанавливаем точку разрыва
p:=random(n_t-2)+2;
//устанавливаем счетчик для prom
u:=1;
//сканирование "второй" хромосомы
for k:=1 to n_t do
//проверяем, содержится ли k-й ген в А
for j:=1 to p do
//если ген содержится в наборе А
if osobi[i*2-1,k]=osobi[i*2,j] then
begin
//копируем его в prom
prom[u]:=osobi[i*2-1,k];
//на его место - ген из набора А
osobi[i*2-1,k]:=osobi[i*2,u];
//увеличиваем счетчик для prom на 1
inc(u);
//выходим из цикла по j
break;
end;
//заменяем гены набора А на гены из prom
for j:=1 to p do osobi[i*2,j]:=prom[j];
end;
end;

procedure mut;
var b:byte;//переменная, через которую
//будем производить обмен
begin
//перебираем всех особей
for i:=1 to n_os do
//решаем, производить ли мутацию
if random(100) begin
//k-номер первого произвольного гена
k:=random(n_t)+1;
//j-номер второго
j:=random(n_t)+1;
//обмен
b:=osobi[i,k];
osobi[i,k]:=osobi[i,j];
osobi[i,j]:=b;
end;
end;

begin
//инициализируем счетчик случайных чисел
randomize;
//генерируем города
gen_towns;
//генерируем начальную популяцию
gen_pop;
//запускаем 5000 поколений
for n:=0 to 5000 do
begin
//селекция
selection;
//кроссовер
crossover;
//и мутация
mut;
end;
read(c);
end.