Dodatek B
Program SGA

Zamieszczamy niżej pełny tekst programu SGA, będącego implementacją elementarnego algorytmu genetycznego w języku Pascal1' (wyd. B.l-B.9). Tekst źródłowy został po-dzielonymiędzydziewięćplików: " ' *
. � � ' � i � : 'Tf*V
sga.pas program główny
interfac.sga interfejs z funkcją celu
stats.sga statystyki populacyjne
initial.sga inicjalizacja
report.sga raporty o stanie populacji
triops.sga reprodukcja, krzyżowanie i mutacja
generate.sga koordynacja następstwa pokoleń
utility.sga wejście-wyjście i inne podprogramy pomocnicze
random.abp generatory liczb pseudolosowych (zob. niżej)
Wszystkie dane wejściowe programu są wprowadzane w trybie dialogowym, a raporty wynikowe zostają wysłane na standardowy plik Turbo Pascala lst skojarzony z drukarką. Plik random.abp zawiera definicje zmiennych globalnych oraz sześć podprogra-mów związanych z generowaniem liczb pseudolosowych. Są to następujące procedury i funkcje:
advance_random warmuprandom random
tworzenie nowego podciągu liczb pseudolosowych inicjalizacja podstawowego generatora liczbapseudolosowazprzedzialu[0,l] Ł
'' W wersji Turbo Pascal 3 rzyp. tlum.)
344
B. Program SGA
flip >.fS. rnd
randomize
wynik symulowanego rzutu monetą (frwe = orzeł) pseudolosowa liczba całkowita z danego zakresu (wybór z jednakowym prawdopodobieństwem) inicjalizacja generatora przy użyciu wartości początkowej podanej przez użytkownika
Podprogramy te są oparte na algorytmach opisanych przez Knutha (1981).
program sga;
{ A Simple Genettc Algorithm - SGA - vl.0 }
{ (c) David Edward Goldberg 1986 }
{ All Rights Reserved }
const raaxpop
maxstring
type allele
- 100;
- 30;
- boolean; ( Allele - bit position )
chromosome - array[l..maxstring] of allele; ( String of bits )
individual record
chrom:chromosome; ( Genotype - bit"string )
x:real; { Phenotype - unsigned integer }
fitness:real; ( Objective function value )
""' parentl, parent2, xsite:integer; ( parents & cross pt }
ii> end; . . ;. ,
population array[l..maxpop] of individual;
var oldpop, newpop:population; ( Two non-overlapping populations ]
popsize, lchrom, gen, maxgen:integer; { Integer global variables )
pcross, pmutation, sumfitness:real; ( Real global variables )
nmutation, ncross:integer; ( Integer statistics )
avg, max, min:real; , ( Real statistics )
( Include utility procedures and functions )
{$I utility.sga ) V
{ Include pseudo-random number generator and random utilities ) {$I random.apb )
( Include interface routines: decode and objfunc ) ($1 interfac.sga )
( Include statistics calculations: statistics ) ($1 stats.sga )
( Include init. routines: inltialize, initdata, initpop, initreport } {$I initial.sga }
{ Include report routines: report, writechrom ) {$I report.sga }
( Include the 3 operators: select (reproduction), crossover, mutation } ($1 triops.sga )
( Include new population generation routine: generation } ($1 generate.sga }
Wyd. B.1. ProgramgłównySGA(pliksga.pas)
B. Program SGA
345
begin { Main program ) gen :- 0; { Set things up ) inittalize; repeat ( Main iterative loop ) , v,,-
gen :- gen + 1;
generation;
statistics(popsize, max, avg, min, sumfitness, newpop);
report(gen);
oldpop : newpop; ( advance the generation } until (gen > maxgen) end. ( End main program )
Wyd. B.1. (cd.)
( interfac.sga: contains objfunc, decode ) ', '
( Change these for different problem ) ..... [
function objfunc(x:real):real;
( Fitness function - f(x) - x**n )
const coef - 1073741823.0; ( Coefficient to normalize domain )
n 10; ( Power of x }
begin objfunc :- power( x/coef, n ) end; !,
function decode(chrora:chroraosorae; lbits:integer):real;
( Decode string as unslgned binary integer - true-1, false-0 )
var j:integer;
accura, powerof2:real; begin
accum :- 0.0; powerof2 :- 1; for j :- 1 to lbits do begin
if chrom[j] then accum :� accum + powerof2; powerof2 : powerof2 * 2; end;
decode : accum; end;
Wyd.B.2.lnterfejszfunkcjacelu(plik/nterfac.sga) ,>.-.��.�.
{ stats.sga }
procedure statistics(popsize:integer;
var raax,avg,min,sumfitness:real; var pop:population); { Calculate population statistics } var j:integer; begin -
{ Initialize >
sumfitness - pop[l].fitness; � � '
min - pop[l].fitness;
max - pop[l].fitness; _Ufu
( Loop for max, min, sumfitness )
for j : 2 to popsize do with pop[j] do begin
surafitness : sumfitness + fitness if fitness>max then max : fitness if fitness{ Calculate average } avg :-sumfitness/popsize; end;
{ Accumulate fitness sum) ( New max ) { New min )
Wyd. B.3. Podprogramy do wyznaczania statystyk populacyjnych (plik stats.sga)
346
B. Program SGA
( initial.sga: contains initdata, initpop, initreport, initialize )
procedure initdata;
( Interactive data inquiry and setup ) var ch:char; j:integer; begin
rewrite(lst); { Set up for list device } { Clear screen )
clrscr;
skip(con,9);
repchar(con,'
repchar(con,'
repchar(con,'
repchar(con,'
repchar(con,'
pause(7); clrscr;
writeln('******** SGA Data Entry and Initialization ************');
writeln;
write('Enter population size .....
write('Enter chromosome length ----
write('Enter max. generations .....
write('Enter crossover probability
write('Enter mutation probability -pause(5); clrscr;
( Initialize random number generator randomize; pause(2); clrscr; ( Initialize counters } �.*.. nmutation : 0; ncross : 0; end;
,25) ; writeln( '................................' ) I
,25); writeln('A Simple Genetic Algorithm - SGA'); ,25); writeln(' (c) David Edward Goldberg 1986'); ,25); writeln(' All Rights Reserved '); , 25) ; writeln('................................' ) '.
readln(popsize);
readln(lchrom); readln(maxgen); readln(pcross); readln(pmutation);
)
procedurę inł ( Initial rep begin writeln(lst, writeln(lst, writeln(lst, writeln(lst, writeln(lst, skip(lst,5); writeln(lst, writeln(lst, writeln(lst) writeln(lst, writeln(lst, writeln(lst, writeln(lst, writeln(lst, sklp(lst,8); writeln(lst, writeln(lst, writeln(lst) writeln(lst, writeln(lst, writeln(lst, writeln(lst, page(lst); { end; treport; iort )
' | A Simple Genetic Algorithm - SGA -' j (c) David Edward Goldberg 1986 ' j All Rights Reserved vi . 0 | ' 1' 1'
' SGA Parameters') ; ' , popsize) ; ' , Ichrom) ; ' , maxgen') ; ' , pcross) ; ' , pmutation) ; ' ,max) ; ' , avg) ; ' ,min) ; ' , sumfitness)
........... --- 1 , ' Population size (popsize) -' Chromosome length (Ichrom) ' Maximum # of generation (maxgen) -' Crossover probability (pcross) ' Mutation probability (pmutation) ' Initial Generation Statistics' ) ;
' Initial population maximura fitness ' Initial population average fitness ' Initial population minimum fitness -' Initial population sum of fitness New page )
Wyd. B.4. Podprogramy inicjalizacji (plik initial.sga)
B. Program SGA
347
procedure initpop;
{ Inttialize a populatlon at random )
varj, jl:integer; ''''
begin '"
for j :- 1 to popsize do with oldpop[j] do begin
for jl :- 1 to lchrom do chrom[jl] :- flip(0.5); ( A fair coin toss } x : decode(chrom,lchrom); ( Decode the string ) fitness :- objfunc(x); ( Evaluate inital fitness ) parentl :- 0; parent2 :- 0; xsite :- 0; ( Initialize printout vars ) end;
en(j. � � . ' - . -� .. � �.- � �� � '� ��.-'
procedure initialize; � f"1
( Initialization Coordinator )
begin ' ' � �'�'
initdata; ; > ": '
initpop; . , ,.,, ,-
statistics(popsize, max, avg, min, sumfitness, oldpop);
initreport; end;
Wyd. B.4. (cd.)
( report.sga: contains writechrom, report ) ' '
procedure writechrom(var out:text; chrom:chromosome; lchrom:integer); ( Write a chromosome as a string of l's (true's) and O's (false's) ) var j:integer; begin for j :- lchrom downto 1 do
if chrom[j] then write(out,'l') *
else write(out,'0'); end;
procedure report(gen:integer); ( Write the population report } const linelength - 132; var j:integer; begin
repchar(lst,
repchar(lst,
repchar(lst,
repchar(lst,
writeln(lst) write(lst, write(lst,
writeln(lst,
repchar(lst,
linelength); writeln(lst);
50); writeln(lst,'Population Report');
23); write(lst,'Generation 57); writeln(lst,'Generation
,gen-l:2); ,gen:2);
string '" # parents xsite');
string
linelength); writeln(lst); for j :- 1 to popsize do begin write(lst,j:2, ') '); ( 01d string ) with oldpop[j] do begin
writechrom(lst,chrom,lchrom); write(lst,' ', x:10, ' ', fitness:6:4, ' end;
Wyd. B.5. Podprogramy do sporządzania raportów (plik report.sga)
fitness'); fitness');
l'):
348
B. Program SGA
( New string )
with newpop[j] do begin
write(lst,' ', j:2, ') (', parentl:2, ',', parent2:2, ')
xsite:2,' '); , ., , .... writechrom(lst,chrom,lchrom); writeln(lst, ' ',x:10,' ', fitness:6:4); end; end;
repchar(lst,'-',linelength); writeln(lst); ( Generation statistics and accumulated values )
writeln(lst,' Note: Generation ', gen:2, ' &Accumulated Statistics: ,' max-', max:6:4,', min-', min:6:4, ', avg-', avg:6:4, ,sumfitness:6:4, ', nmutation', nmutation, ', ncross- ' repchar(lst,'-',linelength); writeln(lst); page(lst); end;
, sum' ncross);
Wyd. B.5. (cd.)
{ triops.sga }
{ 3-operators: Reproduction (select), Crossover (crossover), & Mutation (mutaąion) }
function select(popsize:integer; sumfitness:real;
var pop:population):integer;
{ Select a single individual via roulette wheel select:ion > var rand, partsum:real; { Randora point on wheel, partial sura } j:integer; { popula^tion index }
begin
partsum : 0.0; j :- 0; ( Zero out counter and accumulator )
rand :- random * sumfitness; ( Uheel point calc. uses random number [0,1] ) repeat ( Find wheel slot ) ,
j :- J + 1;
partsum :- partsum + pop[j].fitness; until (partsum > rand) or (j - popsize); ( Return individual number ) select :- j; end;
function mutation(alleleval:allele; pmutation:real;
var nmutation:integer):allele;
( Mutate an allele w/ pmutation, count number of mutations ) var mutate:boolean; begin
rautate :- flip(pmutation); ( Flip the biased coin ) if mutate then begin
nmutation :- nmutation + 1;
mutation :- not alleleval; ( Change bit value ) end else
mutation :- alleleval; ( No change ) end;
Wyd. B.6. Operacjegenetyczne(plikfr7ops.sga)
procedure crossover(var parencl, parent2, childl, child2:chroraosome;
var lchrora, ncross, nrautation, jcross:integer;
var pcross, pmutatlon:real);
{ Cross 2 parent strings, place in 2 child strings ) varj:integer; .-.�-.*�.., ".,..., .
begin '' ' ''''" * "'"' ''''
if flip(pcross) then begin ( Do crossover with p(cross) ) jcross :- rnd(l,lchrom-l); ( Cross between 1 and 1-1 )
1; { Increment crossover counter )
( Otherwise set cross site to force mutation
ncross :- ncross + end else
jcross : lchrom;
( lst exchange, 1 to 1 and 2 to 2 ) for j :- 1 to jcross do begin
childl[j] : mutation(parentl[j], pmutation, nmutation); child2[J] : mutation(parent2[j], pmutation, nmutation); � end; ' '" ~J'$ "'
( 2nd exchange, 1 to 2 and 2 to 1 ]
if jcrossOlchrom then ( Skip if cross site is lchrom--no crossover } for j : jcross+1 to lchrom do begin
childl[j] :-mutation(parent2[j], pmutation, nmutation); child2[j] :-mutation(parentl[j], pmutation, nmutation); end; end;
Wyd. B.6. (cd.
( generate.sga ) . ' t,j-[ ,
procedure generation;
( Create a new generation through select, crossover, and mutation )
( Note: generation assumes an even-numbered popsize ) !l i"vV-
var j, matel, mate2, jcross:integer;
begin
j :- l!
repeat ( select, crossover, and mutation until newpop is filled } matel :- select(popsize, sumfitness, oldpop); ( pick pair of mates )
mate2 : select(popsize, sumfitness, oldpop);
( Crossover and mutation - mutation embedded within crossover ) crossover(oldpop[matel].chrom, oldpop[mate2].chrom, newpop[j ].chrom, newpop[j + l].chrom, lchrom, ncross, nmutation, jcross, pcross, pmutation);
( Decode string, evaluate fitness, & record parentage date on both childr en )
with newpop[j ] do begin . ., ;;; ,,-,-
x :- decode(chrom, lchrom); s-i-.n -,- ;� : '-. � .">-.; �� '�*�.>�" : fitness :- objfunc(x); . ;: �
parentl : matel; i
parent2 :- mate2;
xsite : jcross; - ,
end;
with newpop[j*l] do begin . , . x :- decode(chrom, lchrom); fitness :- objfunc(x); parentl : matel;
parent2 :- mate2; , ,
xsite :- jcross; , �
end;
( Increment population index )
j :- j + 2; , . , , ,
until j>popsize end; ^
Wyd. B.7. Procedura koordynująca następstwo pokoleń (plik generate.sga)
350
B. Program SGA
( utility.sga: contains pause, page, repchar, skip, power
procedure pause(pauselength:integer);
( Pause a while }
const maxpause - 2500; ,
var j,jl:integer; ,
x:real; begin for j : 1 to pauselength do
for jl :- 1 to maxpause do x :- 0.0 + 1.0;
procedure page(var out:text);
( Issue form feed to device or file )
beginwrite(out,chr(12)) end;
procedure repchar(var out:text; ch:char; repcount:integer);
{ Repeatedly write a character to an output device }
var j:integer;
begin for j :- 1 to repcount do write(out,ch) end;
procedure skip(var out:text; skipcount:integer);
{ Skip skipcount lines on device out )
var j:integer;
begin for j :- 1 to skipcount do writeln(out) end;
functionpower(x,y:real):real; ( fl>;;sr�n,!;
( Raise x to the yth power )
begin power :- exp( y*ln(x) ) end; nfttj'*-,. ->vi �
Wyd. B.8. Podprogramy wejścia-wyjścia i inne podprogramy pomocnicze (plik utility.sga)
( random.apb: contains random number generator and related utiIities
including advance random, warmup_random, random, randomize, flip, rnd }
( Global variables - Don't use these names in other code ) var oldrand:array[1..55] of real; ( Array of 55 random numbers ) jrand:integer; ( current'random ) ,
procedure advance_random; ' '�
{ Create next batch of 55 random numbers ) ' : var jl:integer;
new_random:real; begin
for jl:- 1 to 24 do � '
begin
new_random :- oldrand[jl] - oldrand[jl+31]; if (new_random < 0.0) then new_random :- new_random + 1.0; oldrand[jl] :- new_random; end;
for jl:- 25 to 55 do begin
new_random :- oldrand[jl] - oldrand[jl-24]; if (new_random < 0.0) then new_random :- new_random + 1.0; oldrand[jl] :- new_random; ;
end; end;
Wyd. B.9. Podprogramygeneratoraliczbpseudolosowych(plikranofom.abp)
B. Program SGA
351
procedure warmup_random(random_seed:real); ( Get random off and runnin ) var jl,ii:integer;
new_random,prev_random:real;
begin n
oldrand[55] :- random_seed; "� ;
new_random : l.Oe-9; -* ''
prev_random :- random_seed; for jl:-l to 54 do begin
ii :- 21*jl mod 55; oldrand[ii] : new_randora; new_random : prev_random - new_randora; if (new_random < 0.0) then new_random:-new_random+1.0; prev_random:oldrand[i i] end;
advance_random; advance_random; advance_random; jrand:-0; end;
function random:real;
{ Fetch a single random number between 0.0 and 1.0
( See Knuth, D. (1969), v. 2 for details
begin
jrand :- jrand + 1;
if (jrand > 55) then begin jrand:-l; advance_random end;
random : oldrand[Jrand]; end;
function flip(probability:real):boolean; ( Flip a biased coin - true if heads ) begin '�
if probability - 1.0 then flip :- true
else flip :- (random <- probability); end;
function rnd(low,high:integer):integer; ( Pick a random integer between low and high } var i:integer; begin
if low >- high then i :- low else begin
i :- trunc( random * (high-low+1) + low); if i > high then i :- high; end; rnd :- i;
end;
't
procedure randomize;
( Get seed number for random and start it up }
var randomseed:real;
begin
repeat write('Enter seed random number (O.0..1.0) >
until (randomseed>0) and (randomseed<1.0);
warmup_random(randomseed); end; ' � .
Wyd. B.9. (cd.) ' ! *
- Subtractive Method ) ł
1); readln(randomseed);