Listing aero.PAS
Program Aeroport_Algoritm_Genetic;
uses Crt;
const popsize=10;
ppm=0.2;{Probab. initiala de mutatie }
pi=0.6; {Probabilitate de incrucisare }
type cromozom=array[1..100] of Byte;
var f:Text;
pm:Real;
a:array[1..100,1..100] of Byte;
orase:array[1..100] of String[40];
nrn,nri,nri1,m,n,nro:Byte;
nr,gen,min,p:Longint;
fol:array[0..100] of Boolean;
p1,p2,sol,pr:cromozom;
pp,pp1,pop:array[1..popsize] of cromozom;
c:array[1..100] of Longint;
c1:array[0..100] of Real;
Procedure
afisare; forward;
Function cod(var s:String):Byte;
var i:Byte;
begin
for i:=1 to nro do
if orase[i]=s
then begin cod:=i; Exit end;
Inc(nro); orase[nro]:=s; cod:=nro
end;
Procedure citire;
var s1,s2:String; c:Char;
begin
Assign(f,'aero.in'); Reset(f);
Readln(f,n,m); nro:=0;
while not SeekEof(f) do
begin
s1:='';
repeat Read(f,c); s1:=s1+c until c=' ';
s2:='';
repeat Read(f,c); s2:=s2+c until c=' ';
Readln(f,p); a[cod(s1),cod(s2)]:=p
end;
Close(f);
if nro=0 then afisare
end;
Function cost:Longint;
var c:Longint; i,j:Byte;
begin
c:=0;
for i:=1 to nro do
for j:=1 to nro do
if a[i][j]>0
then
if pr[i] div m=pr[j] div m
then Inc(c,a[i][j]*Abs(pr[i]-pr[j]))
else Inc(c,a[i][j]*(pr[i] mod m +
pr[j] mod m + 2 +
Abs(pr[i] div m - pr[j] div m)));
cost:=c
end;
Procedure afisare;
var i:Byte;
begin
Assign(f,'aero.out'); Rewrite(f);
Writeln(f,min);
for i:=1 to nro do
Writeln(f,orase[i],sol[i]+1);
Close(f); Halt
end;
Procedure mutant(x:Byte);
var i,y,poz,poz1:Byte;
a:set of Byte;
begin
repeat
poz:=Random(nro)+1; poz1:=Random(nro)+1;
until poz<>poz1;
a:=[];
for i:=1 to nro do a:=a+[pop[x][i]];
a:=a-[pop[x][poz]]; a:=a-[pop[x][poz1]];
repeat
y:=Random(m*n)
until not (y in a ) and (y<>pop[x][poz]);
pop[x][poz]:=y; a:=a+[y];
repeat
y:=Random(m*n)
until not (y in a ) and (y<>pop[x][poz1]);
pop[x][poz1]:=y; pr:=pop[x];
if cost<min
then
begin min:=cost; Writeln(min); sol:=pr end
end;
Procedure mutatie;
var i:Byte;
begin
for i:=1 to popsize do
if Random<pm then mutant(i)
end;
Procedure imperecheaza;
var i,x,y,j,poz:Byte;
a,b:set of Byte;
begin
a:=[]; b:=[]; poz:=Random(nro-2)+1;
for i:=1 to poz do
begin a:=a+[p1[i]]; b:=b+[p2[i]] end;
for i:=poz+1 to nro do
begin
x:=p1[i]; y:=p2[i]; j:=0;
while true do
begin
if y+j < m*n
then
if not ((y+j) in a )
then
begin
a:=a+[y+j]; p1[i]:=y+j; Break
end;
if y-j>=0
then
if not ((y-j) in a )
then
begin
a:=a+[y-j]; p1[i]:=y-j; Break
end;
Inc(j)
end;
j:=0;
while true do
begin
if x+j<m*n
then
if not ((x+j) in b )
then
begin
b:=b+[x+j]; p2[i]:=x+j; Break
end;
if x-j>=0
then
if not ((x-j) in b )
then
begin
b:=b+[x-j]; p2[i]:=x-j; Break
end;
Inc(j)
end
end
end;
Procedure recombina;
var i,x,a:Byte;
begin
nri1:=nri; x:=nri div 2; i:=1;
while i<=x do
begin
a:=Random(nri)+1; Dec(nri);
p1:=pp[a]; pp[a]:=pp[nri+1];
a:=Random(nri)+1; Dec(nri);
p2:=pp[a]; pp[a]:=pp[nri+1];
Inc(i);
imperecheaza;
pp[nri+1]:=p1; pp[nri+2]:=p2; pr:=p1;
if cost<min
then
begin
min:=cost; Writeln(min); sol:=pr
end;
pr:=p2;
if cost<min
then
begin
min:=cost; Writeln(min); sol:=pr
end
end
end;
Procedure Incrucisare;
var i:Byte;
begin
nri:=0; nrn:=0;
for i:=1 to popsize do
if Random<pi
then begin Inc(nri); pp[nri]:=pop[i] end
else begin Inc(nrn);pp1[nrn]:=pop[i] end;
recombina
end;
Procedure selectie;
var j,i:Byte; max:Longint; x:Real;
begin
max:=0;
for i:=1 to popsize do
begin
pr:=pop[i]; c[i]:=cost;
if max < c[i] then max:=c[i]
end;
c1[0]:=0;
for i:=1 to popsize do
c1[i]:= c1[i-1]+1.0*max/c[i];
for i:=1 to popsize do
c1[i]:=c1[i] / c1[popsize];
for i:=1 to popsize do
begin
x:=Random; j:=1;
while c1[j]<x do Inc(j);
pp[i]:=pop[j]
end;
pop:=pp
end;
Procedure generatie;
var i:Byte;
begin
selectie;
mutatie;
Incrucisare;
pop:=pp;
for i:=nri1+1 to nro do
pop[i]:=pp1[i-nri1+1];
pop[popsize]:=sol
end;
Procedure crom(x:Byte);
var y,i:Byte;
begin
FillChar(fol,Sizeof(fol),false);
for i:=1 to nro do
begin
repeat y:=Random(m*n) until not fol[y];
fol[y]:=true;
pop[x][i]:=y
end;
pr:=pop[x];
if cost<min
then
begin
min:=cost; Writeln(min); sol:=pr
end
end;
Procedure initializare;
var i:Byte;
begin
for i:=1 to popsize do crom(i)
end;
Begin
Randomize;
citire;
min:=Maxlongint;
initializare;
gen:=1;
pm:=ppm;
repeat
if gen mod 1000 = 0 then pm:=pm*1.1;
generatie;
Inc(gen)
until Keypressed;
afisare
End.