codice:
unit Threads;
interface
uses
Dialogs,Main,ComCtrls,Classes, Graphics, ExtCtrls,stdctrls,sysUtils,Math;
type
MIO = integer;
const
MAXPOP=100;
MAXLENGTH=300;
type
{ TFranzThread }
TFranzThread = class(TThread)
private
FListBox:TListBox; // listbox a scopo debug
FSeed:integer; // seme random
FPM:double; // mutazione
FPC:double; //probabilità crossover
FChoice:integer; //funzione
FMaxCicli:integer; //max num cicli
FEpoca:integer; // cicli per output
FObjectiveMin: integer; // indice individuo migliore
FSoluzioneMigliore:string; // soluzione migliore in stringa
FProgressBarbestsol:TProgressBar;
FProgressBarFomin:TProgressBar;
Flblbestsol:TLabel;
FlblFomin:TLabel;
FIterazione: integer;
Fbestsol: double;
FFomin: double;
FFomax: double;
FOutputSuFile:boolean; // se true output su FFileOutput
FNomeFileOutput:string; // nome file di output
FHandleFileOutput:textfile;
procedure doMostraMinimo;
protected
procedure Execute; override;
procedure MostraMinimo(iterazione:integer;var bestsol:double;var fomin:double;var fomax:double;individuoMigliore:string);
public
constructor Create(outputSuFile:boolean;nomeFile:string;choice:integer;var lblbestsol:TLabel;var lblFomin:Tlabel;var lbListBox:TListBox;var pgrProgressbestsol:TProgressBar;var pgrProgressFomin:TProgressBar;seed:integer;mutazione:double;crossover:double;maxcicli:integer;epoca:integer);
end;
TMINGenetico = class(TFranzThread)
private
numvar,bitvar,maxlen:longint;
deno:longint;
pop: array [0..MAXPOP,0..MAXLENGTH] of MIO;
fitness: array [0..MAXPOP] of double;
incfitness: array [0..MAXPOP] of double;
bestsol:double;
protected
procedure Execute; override;
function getrandom(var x:longint;max:double):double;
function gauss(var x:longint):double;
function conver(k:integer;riga:integer):double;
function clcobj(line:integer):double;
procedure makeselection;
procedure compact(var vetcomp:array of MIO;canc:integer;cicle:integer);
procedure makexover;
procedure makemutation;
procedure Minimizza;
end;
implementation
constructor TFranzThread.Create(outputSuFile:boolean;nomeFile:string;choice:integer;var lblbestsol:TLabel;var lblFomin:Tlabel;var lbListBox:TListBox;var pgrProgressbestsol:TProgressBar;var pgrProgressFomin:TProgressBar;seed:integer;mutazione:double;crossover:double;maxcicli:integer;epoca:integer);
begin
FOutputSuFile:=outputsufile;
FNomeFileOutput:=nomeFile;
FListBox:=lbListBox;
FProgressBarbestsol:=pgrProgressbestsol;
FProgressBarFomin:=pgrProgressFomin;
Flblbestsol:=lblbestsol;
FlblFomin:=lblFomin;
FSeed:=seed;
FPM:=mutazione;
FMaxCicli:=maxcicli;
FEpoca:=epoca;
FPC:=crossover;
FChoice:=choice;
FObjectiveMin:=0;
FreeOnTerminate := True;
inherited Create(False);
end;
procedure TFranzThread.DoMostraMinimo;
begin
FLblbestsol.caption:='IT '+inttostr(fiterazione)+' '+format('%10.6f',[fbestsol]);
FLblFomin.caption :=FSoluzioneMigliore;
if FBestSol<>0 then
FProgressbarFomin.position:=trunc((1.0/(FBestSol))*Ffomin);
FProgressbarbestsol.position:=trunc(10000*FBestSol);
if FOutputSuFile then
writeln(FHandleFileOutput,Format('Iterazione |%06d| %s',[fiterazione,FsoluzioneMigliore]));
end;
procedure TFranzThread.MostraMinimo(iterazione:integer;var bestsol:double;var fomin:double;var fomax:double;individuoMigliore:string);
begin
FSoluzioneMigliore:=individuoMigliore;
FIterazione:=iterazione;
Fbestsol:=bestsol;
FFomin:=Fomin;
FFomax:=fomax;
Synchronize(DoMostraMinimo);
end;
procedure TFranzThread.Execute;
begin
end;
procedure TMinGENETICO.Execute;
begin
Minimizza;
end;
function TMINGenetico.getrandom(var x:longint;max:double):double;
var
y:longint;
yfl:double;
begin
y := x * 1220703125;
if (y<0) then
begin
y :=y+2147483647;
INC(y);
end;
x:=y;
yfl :=y;
yfl :=yfl*0.4656613E-9;
if max=1 then
getrandom:=yfl
else
getrandom:=y mod (trunc(max+1));
end;
// generiamo una v.a. distribuita normalmente (teorema limite centrale)
// con media 3 , var. e sigma = 1
// prendo media 3 e non 6 per limitare i rischi di
// grandi valori negativi che potrebbero creare problemi nella
// minimizzazione
function TMINGenetico.gauss(var x:longint):double;
var somma:double;
i:integer;
begin
somma:=0;
for i:=1 to 12 do
somma:=somma+getrandom(x,1);
result:=somma-3.0;
end;
// converte la K-esima variabile dell'individuo riga
function TMINGenetico.conver(k:integer;riga:integer):double;
var j:integer;
cont:double;
begin
cont:=0;
for j:=0 to bitvar-1 do
begin
//cont:=cont+power(2,bitvar-1-j)*pop[riga,k*bitvar+j];
cont:=cont+(1 shl (bitvar-1-j))*pop[riga,k*bitvar+j];
end;
//cont:=(cont-power(2,bitvar-1))/deno;
cont:=(cont-(1 shl (bitvar-1)))/deno;
result:=cont;
end;
// nota: niente fronzoli, niente puntatori a funzioni, etc.
function TMINGenetico.clcobj(line:integer):double;
var val,val1,x1,x2,x3:double;
i:integer;
begin
VAL:=0;
val1:=0;
case (Fchoice) of
1: begin
for i:=0 to numvar-1 do
begin
val1:=conver(i,line);
val:=val+val1*val1;
end;
end;
2: begin
x1:=conver(0,line);
x2:=conver(1,line);
val:=100*(power((x1*x1)-x2,2)+power((1-x1),2)); // usato volutamente power() e non la moltiplicazione
// per rallentare l'esecuzione
end;
3: begin
for i:=0 to numvar-1 do
val:=val+trunc(conver(i,line));
end;
4: begin
for i:=0 to numvar-1 do
begin
val1:=conver(i,line);
val:=val+i*val1*val1*val1*val1;
end;
val:=val+gauss(Fseed);
end;
5: begin
x1:=conver(0,line);
x2:=conver(1,line);
x3:=conver(2,line);
val:=abs(x1*18+x2*48+x3*42-600);
if x1<=0 then val:=val+600;
if x2<=0 then val:=val+600;
if x3<=0 then val:=val+600;
if (x1+x2+x3)<>20 then val:=val+600;
end;
end;
result:=val;
end;
// riproduzione
procedure TMINGenetico.makeselection;
var
i,k,linecopy:integer;
pos:double;
popsel:array[0..MAXPOP,0..MAXLENGTH] of MIO;
begin
// metto in incfitness[] la fitness[] incrementale (somma da 0 a i delle fitness[i])
incfitness[0]:=fitness[0];
for k:=1 to MAXPOP-1 do
begin
incfitness[k]:=incfitness[k-1]+fitness[k];
end;
for k:=0 to MAXPOP-1 do
begin
// genero numero casuale compreso tra 1 e il valore della fitness cumulata
pos:=(getrandom(Fseed,trunc(incfitness[MAXPOP-1])));
// trova l'indice linecopy (all'interno della fitness cumulata) che e' >= di pos
linecopy:=0;
while(incfitness[linecopy]<pos) do
INC(linecopy);
for i:=0 to maxlen-1 do
popsel[k,i]:=pop[linecopy,i];
end;
for i:=0 to MAXPOP-1 do
for k:=0 to maxlen-1 do
pop[i,k]:=popsel[i,k];
end;
procedure TMINGenetico.compact(var vetcomp:array of MIO;canc:integer;cicle:integer);
var ind,ind1:integer;
begin
ind:=0;
while(vetcomp[ind]<>canc) do
INC(ind);
for ind1:=ind to cicle-1 do
vetcomp[ind1]:=vetcomp[ind1+1];
end;
procedure TMINGenetico.makexover;
var
num:array[0..MAXPOP] of MIO; // MIO
couple:array[0..MAXPOP] of integer;
temp:MIO; //MIO
i,j,xcut,temp1:integer;
begin
temp1:=MAXPOP;
// inizializza vettore num[] a 0,1,2,...MAXPOP-1
for i:=0 to MAXPOP-1 do
num[i]:=i;
// genera le coppie candidate per il crossover
for i:=0 to MAXPOP-1 do
begin
couple[i]:=num[trunc(getrandom(Fseed,temp1-1))];
compact(num,couple[i],temp1);
DEC(temp1);
end;
i:=0;
while (i<MAXPOP) do
//for(i=0;i<MAXPOP;i+=2)
begin
if(getrandom(Fseed,1)<=Fpc) then
begin
xcut:=trunc(getrandom(Fseed,maxlen-1));
for j:=xcut to maxlen-1 do
begin
temp := pop[couple[i],j];
pop[couple[i],j] := pop[couple[i+1],j];
pop[couple[i+1],j] := temp;
end;
end;
i:=i+2;
end;
end;
procedure TMINGenetico.makemutation;
var i,j:integer;
test:double;
begin
for i:=0 to MAXPOP-1 do
for j:=0 to maxlen-1 do
begin
test:=Fpm;
if (getrandom(Fseed,1)<=test) then
begin
//pop[i,j] := not pop[i,j];
if pop[i,j]=1 then pop[i,j]:=0 else pop[i,j]:=1; // nota: i numeri in Pascal sono SIGNED.
// questo rallenta, ma rende sicuri
end;
end;
end;
procedure TMINGenetico.Minimizza;
var n,i,j,k:integer;
objective:array [0..MAXPOP] of double;
fomin,fomax:double;
numit:integer;
individuoSoluzioneMigliore:integer;
soluzioneMigliore:string;
variabile:double;
begin
if FOutputSuFile then
begin
try
AssignFile(FHandleFileOutput,FNomeFileOutput);
if FileExists(FNomeFIleOutput) then
append(FHandleFileOutput)
else
Rewrite(FHandleFileOutput);
except
FOutputSuFile:=false;
end;
end;
case Fchoice of
1: begin
numvar:=3;
bitvar:=10;
deno:=100;
end;
2: begin
numvar:=2;
bitvar:=12;
deno:=1000;
end;
3: begin
numvar:=5;
bitvar:=10;
deno:=100;
end;
4: begin
numvar:=30;
bitvar:=8;
deno:=100;
end;
5: begin
numvar:=3;
bitvar:=6;
deno:=1;
end;
end;
if FOutputSuFile then
writeln(FHandleFileOutput,Format('Funzione %d Iterazioni %06d Mutazione %6.3f Xver %6.3f seed %d',[Fchoice,FMaxCicli,FPM,FPC,FSeed]));
maxlen:=numvar*bitvar;
for i:=0 to MAXPOP-1 do
for j:=0 to maxlen-1 do
pop[i,j]:=trunc(getrandom(fseed,1)+0.5);
fomin:=0;
fomax:=0;
bestsol:=10000000;
for numit:=0 to Fmaxcicli do
begin
if Terminated then
begin
if FOutputSuFile then closefile(FHandleFileOutput);
exit;
end;
individuoSoluzioneMigliore:=-1;
for n:=0 to MAXPOP-1 do
begin
// calcola funzioni obiettivo e le mette in objective[]
objective[n]:=clcobj(n);
// setta fomin e fomax al min,max delle funzioni obiettivo della popolazione
if (objective[n]<fomin) OR (n=0) then
fomin:=objective[n];
if (objective[n]>fomax) OR (n=0) then
fomax:=objective[n];
if objective[n]<bestsol then
begin
bestsol:=objective[n];
individuosoluzionemigliore:=n;
end;
end;
// test ad ogni generazione (anche se non Epoca). Usato per il debug
if individuoSoluzioneMigliore>-1 then
begin
soluzioneMigliore:='';
for k:=0 to numvar-1 do
begin
variabile:=conver(k,individuoSoluzioneMigliore);
soluzioneMigliore:=SOLUZIONemigliore+ format('%8.3f|',[variabile]);
end;
soluzioneMigliore:=format('%10.6f | %s',[bestsol,soluzioneMigliore]);
end;
// ora di collezionare output?
if (numit mod Fepoca)=0 then
MostraMinimo(numit,bestsol,fomin,fomax,soluzioneMigliore);
// calcola fitness con metodo silly (niente window o sigma scaling)
for n:=0 to MAXPOP-1 do
begin
fitness[n]:=fomax-objective[n];
end;
// operatori genetici
makeselection;
makexover;
makemutation;
// abbiamo una soluzione migliore? Si' aggiorna bestsol (nota:sarebbe bestmin...)
end;
if FOutputSuFile then
closefile(FHandleFileOutput);
end;
end.