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.