begin

a:=true; b:=true; i:=0; j:=0;

for k:=0 to Kol do begin

a:=a and (otb[x,k]*ran[2,k]>otb[y,k]*ran[2,k]);

b:=b and (otb[x,k]*ran[2,k]<otb[y,k]*ran[2,k]);

end;

if not(a or b) then begin

for k:=0 to Kol do begin

i:=i+otb[x,k]*ran[2,k];

j:=j+otb[y,k]*ran[2,k];

end;

a:=(i>j);

end;

if a then paret:=0 else

if b then paret:=1 else

paret:=-1;

end;

procedure elem(Kol,Num:word);

var i:word; {Kol - количество критериев

Num - номер элемента }

begin

for i:=0 to Kol do

otb[Num,i]:=random(ran[1,i]-ran[0,i])+ran[0,i];

end;

procedure SORT;

var i,j,k,l:word; pr:tbyte;

begin

for i:=0 to N do begin

k:=i;

for j:=i+1 to N do

if paret(M,k,j)=0 then k:=j;

for l:=0 to M do begin

pr:=otb[i,l];

otb[i,l]:=otb[k,l];

otb[k,l]:=pr;

end;

end;

end;

procedure Pretendent(Kol:word);{ Kol - количество критериев }

var num,num1:word; k:shortint;

begin num:=random(N+1);

{номер удаляемого элемента }

j:=0;

repeat

repeat

num1:=random(N+1); { номер рекомендателя }

until num<>num1;

elem(Kol,Num);

k:=paret(Kol,Num,Num1);

inc(j);

until (k=0) or (j>3*N);

end;

procedure Propolka(Num,Kol,typ:word);

{ Num - количество изымаемых элементов

Kol - количество критериев

typ=0 - прополка; typ=1 - сбор урожая;}

var i,m,j:word;

begin

SORT;

if typ=0 then begin m:=0; j:=Num; end

else begin m:=N-Num; j:=N; end;

for i:=m to j do

elem(Kol,i);

end;

procedure Delegation(Kol,Num,Kk:word);

{ Kol - количество элементов в делегирующей группе

Num - номер делегата в элитной группе }

var

i,j,mn,mx:word;

begin

for i:=0 to Kol do

elem(Kk,i+N);

mx:=0;

for i:=1 to kol do

if paret(Kk,i+N,mx+N)=0 then mx:=i;

for i:=0 to Kk do

otb[Num,i]:=otb[mx+N,i];

end;

procedure ShowQuality(typ,Kol,Num:word);

var i,j:word;S:tbyte;

f:extended;

begin

if typ=0 then begin

clrscr;

write(' Процедура ');

case Num of

2: writeln('"Претендент-рекомендатель"');

3: writeln('"Прополка"');

4: writeln('"Сбор урожая"');

5: writeln('"Делегирование"');

0:;

end;

writeln;

writeln('Среднее арифметическое показателей элитной группы');

writeln(' по различным критериям до и после моделирования.');

writeln('+—————————————————————+');

writeln('¦NN¦Начальные показатели¦ После отбора ¦');

writeln('+—+——————————+—————————¦');

end;

for i:=0 to Kol do begin

if typ=0 then begin

gotoxy(1,i+7);

write('¦',i+1:2,'¦ ','¦':19,'¦':22);

end;

gotoxy(6+typ*23,i+7);

s:=0;

for j:=0 to N do

S:=S+otb[j,i];

f:=S/(N+1);

write(f:9:6);

end;

writeln;

writeln('+—————————————————+');

if typ=1 then c:=readkey;

end;

procedure input(Num:byte);

var nm2,test:byte;

begin

test:=0;

repeat

nm2:=menu(2);

if (nm2<>6) and (nm2<>0) and (nm2<>4) then test:=1;

case nm2 of

1: begin

writeln('Введите количество критериев отбора(до 20): ');

readln(t);

if t>=20 then t:=20;

if t<1 then t:=1;

dec(t);

flag:=0; flag:=flag or 1;

end;

2: if (flag and 1)=1 then

for j:=0 to t do begin

writeln('Введите разброс значений ',(j+1):-3,' критерия ');

readln(ran[0,j],ran[1,j]);

writeln('Введите приоритет ',(j+1):-3,' критерия');

readln(ran[2,j]);

flag:=flag or 2;

end;

3: begin

writeln('Введите размер элитной группы(до 200)');

readln(N);

if N>=200 then n:=200;

if N<1 then n:=1;

dec(n);

if (num in [3,4]) then begin

writeln('Сколько элементов удалять на каждом шаге');

readln(z);

if z>n then z:=n-1;

if z<1 then z:=1;

end;

flag:=flag or 4;

end;

4: if Num=5 then begin

writeln('Введите размер делегирующей группы(до 400)');

readln(dl);

if dl>=400 then dl:=400;

if dl<1 then dl:=1;

end;

5: begin

writeln('Введите количество циклов жизни элитной группы (до 4000)');

readln(f);

if f>=4000 then f:=4000;

if f<1 then f:=1;

flag:=flag or 8;

end;

0,6: ;

end;

until (flag=15) and ((nm2=0) or (nm2=6));

if test=1 then begin

for i:=0 to n do elem(t,i);

for i:=0 to n do

for j:=0 to t do

otb[i+n+ck,j]:=otb[i,j];

end else

for i:=0 to n do

for j:=0 to t do

otb[i,j]:=otb[i+n+ck,j];

ShowQuality(0,t,Num);

for i:=1 to f do begin

case Num of

2: pretendent(t);

3: propolka(z,t,0);

4: propolka(z,t,1);

5: begin

j:=random(N); delegation(dl,j,t);

end;

end;

gotoxy(75,1);write(i:4);

if keypressed then

if readkey=#27 then break;

end;

Showquality(1,t,0);

end;

procedure help;

const attr=blue*16+Lightgreen;

begin

window(23,7,56,18);

highvideo;

FrameWin('Справка',DoubleFrame,Attr,Attr);

textbackground(blue);

textcolor(Lightgreen);

gotoxy(2,1);

clrscr;

writeln(' Эволюция элитных групп');

writeln;

writeln(' Создана студентами ');

writeln(' группы 6-19-2'); writeln;

writeln(' Авторы:');

writeln(' Григорьев Максим');

writeln(' Леонидович');

writeln(' Руденко Виталий Николаевич');

textbackground(black);

textcolor(white);

normvideo;

window(1,1,80,25);

readln;

end;

begin

clrscr; n:=0;b:=false;

repeat

nm:=menu(1);

case nm of

1: help;

2,3,4,5: input(nm);

0,6: b:=true;

end;

clrscr;

until b;

end.

ПРИЛОЖЕНИЕ 2. РЕЗУЛЬТАТЫ ТЕСТИРОВАНИЯ ПРОГРАММЫ