Listing COLOANE.PAS 
Program Coloane_Algoritm_Genetic; 
uses Crt; 
const popsize=10; { numarul de cromozomi } 
ppm=0.2; 
{ probabilitatea initiala de mutatie } 
pc=0.6;{ probabilitatea de recombinare} 
type cromozom=array[1..200] of Byte; 
var a:array[1..200,1..200] of Byte; 
f:Text; 
m,n:Byte; gen:Longint; 
pp1,pp,pop:array[1..popsize] of cromozom; 
p1,p2,sol,testat:cromozom; 
c:array[1..200]of Boolean; 
c1:array[1..200]of Integer; 
c2:array[0..200]of Real; 
nri1,nri,nrn,maxim:Integer; 
pm:Real; 
procedure citire; 
var i,j:Byte; 
begin 
Assign(f,'COLOANE.IN'); Reset(f); 
Readln(f,m,n); 
for i:=1 to m do 
for j:=1 to n do Read(f,a[i][j]); 
Close(f) 
end; 
procedure farasolutie; 
begin 
Assign(f,'COLOANE.OUT'); Rewrite(f); 
Writeln(f,0); 
Close(f); 
Halt 
end; 
procedure verificare; 
var i,j,nr:Byte; 
begin { se verifica existenta unei solutii } 
for i:=1 to m do 
begin 
nr:=0; 
for j:=1 to n do nr:=nr+a[i][j]; 
if nr=0 then farasolutie 
end 
end; 
function punctaj: integer; 
var i,j:Byte; 
pt:Integer; 
da:Boolean; 
begin 
Fillchar(c,Sizeof(c),false); 
pt:=4*n+1; 
{ se scade numarul de coloane selectate } 
for i:=1 to n do 
if testat[i]=1 
then 
begin 
Dec(pt); 
for j:=1 to m do 
if a[j][i]=1 then c[j]:=true 
end; 
da:= false; 
{ se scade de doua ori numarul de linii } 
{ pentru care suma elementelor de pe } 
{ linie este 0 } 
for i:=1 to m do 
if not c[i] 
then 
begin 
Dec(pt,2); da:=true 
end; 
{ in cazul in care a existat cel } 
{ putin o linie pentru care suma } 
{ elementelor a fost 0 se mai scade n } 
if da then Dec(pt, n); 
punctaj:=pt 
end; 
procedure selectie; 
var i,j:Byte; x:Real; 
begin 
for i:=1 to popsize do 
begin { se calculeaza punctajele } 
testat:=pop[i]; c1[i]:=punctaj 
end; 
c2[0]:=0; 
{ se determina probabilitatea de selectie } 
for i:=1 to popsize do 
c2[i]:=c2[i-1]+c1[i]; 
for i:=1 to popsize do 
c2[i]:=c2[i]/c2[popsize]; 
{ se selecteaza cromozomii } 
for i:=1 to popsize do 
begin 
x:=Random; 
j:=1; 
while c2[j]<x do Inc(j); 
pp[i]:=pop[j] 
end; 
pop:=pp 
end; 
procedure mutant(x:Byte); 
var poz:Byte; 
begin 
{ se alege gena care va fi, modificata } 
poz:=Random(n)+1; 
{ se modifica gena } 
pop[x][poz]:=1-pop[x][poz]; 
{ se tasteaza adaptarea noului cromozom } 
testat:=pop[x]; 
if punctaj>maxim 
then 
begin maxim:=punctaj; sol:=testat end 
end; 
procedure mutatie; 
var i:Byte; 
begin 
for i:=1 to popsize do 
if pm>Random then mutant(i) 
end; 
procedure imperecheaza; 
var i,poz1,poz2:Byte; 
begin { se determina pozitiile intre } 
{ care vor fi schimbate genele } 
poz1:=Random(n-2)+1; 
poz2:=Random(n-2)+1; 
if poz1>poz2 
then 
begin 
{ poz1 trebuie sa fie mai mic decat poz2 } 
poz1:=poz1 xor poz2; 
poz2:=poz1 xor poz2; 
poz1:=poz1 xor poz2 
end; 
{ se modifica genele } 
for i:=poz1+1 to poz2 do 
begin 
p1[i]:=p1[i] xor p2[i]; 
p2[i]:=p1[i] xor p2[i]; 
p1[i]:=p1[i] xor p2[i] 
end 
end; 
procedure recombina; 
var a,i,x:Byte; 
begin 
nri1:=nri; 
x:=nri div 2; 
i:=1; 
while i<=x do 
begin 
{ se selecteaza o pereche de cromozomi } 
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; 
{ cromozomii nou obtinuti isi inlocuiesc } 
{ parintii in populatie } 
pp[nri+1]:=p1; 
pp[nri+2]:=p2; 
{ se testeaza adaptabilitatea } 
{ noilor cromozomi } 
testat:=p1; 
if punctaj>maxim 
then 
begin maxim:=punctaj; sol:=testat end; 
testat:=p2; 
if punctaj>maxim 
then 
begin maxim:=punctaj; sol:=testat end 
end 
end; 
procedure incrucisare; 
var i:Byte; 
begin 
nri:=0; 
nrn:=0; 
{ se selecteaza cromozomii } 
{ care vor fi recombinati } 
for i:=1 to popsize do 
if Random<pc 
then 
begin 
Inc(nri); pp[nri]:=pop[i] 
end 
else 
begin 
Inc(nrn); pp1[nrn]:=pop[i] 
end; 
recombina 
end; 
procedure generatie; 
var i:Byte; 
begin 
selectie; 
mutatie; 
incrucisare; 
{ se creeaza noua populatie } 
pop:=pp; 
for i:=nri1+1 to popsize do 
pop[i]:=pp1[i-nri1+1]; 
pop[Random(popsize)+1]:=sol 
end; 
procedure initializare; 
var i,j:Byte; 
begin { se genereaza aleator structura } 
{ primilor noua cromozomi } 
for i:=1 to popsize - 1 do 
for j:=1 to n do 
pop[i][j]:=Random(2); 
{ al zecelea cromozom va fi cel } 
{ corespunzator cazului in care } 
{ toate coloanele ar fi selectate } 
for j:=1 to n do pop[popsize][j]:=1; 
{ se testeaza adaptabilitatea cromozomilor } 
for i:=1 to popsize do 
begin 
testat:=pop[i]; 
if punctaj>maxim 
then 
begin 
maxim:=punctaj; 
sol:=testat 
end 
end 
end; 
procedure afisare; 
var i,nr:Byte; 
begin 
Assign(f,'coloane.out'); Rewrite(f); 
nr:=0; 
{ se numara coloanele selectate } 
for i:=1 to n do Inc(nr,sol[i]); 
Writeln(f,nr); 
for i:=1 to n do 
if sol[i]=1 then Write(f,i,' '); 
Writeln(f); 
Close(f) 
end; 
Begin 
Clrscr; 
Randomize; 
citire; 
verificare; 
initializare; 
pm:=ppm; 
gen:=1; 
repeat 
if gen mod 100=0 
then pm:=pm*1.1; 
{ creste probabilitatea de mutatie } 
generatie; 
Inc(gen) 
until Keypressed; { executia se termina } 
afisare { la apasarea unei taste } 
End.