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.