operator.dom

Pascal Programs Printed in GENETIC ALGORITHMS IN SEARCH, OPTIMIZATION, AND MACHINE LEARNING by Da

{ operator.dom }
{ operators:   Reproduction (select), Crossover (crossover),
               Mutation (mutation), Dominance (mapdominance,
               dominance                                      }

function select(popsize:integer; sumfitness:real;
                var pop:population):integer;
{ Select a single individual via roulette wheel selection }
var rand, partsum:real; { Random point on wheel, partial sum }
    j:integer;          { population index }
begin
 partsum := 0.0; j := 0;      { Zero out counter, accumulator }
 rand := random * sumfitness; { Wheel point calc. w/rng [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; temp:allele;
begin
 mutate := flip(pmutation);   { Flip the biased coin }
 if mutate then begin
   nmutation := nmutation + 1;
   temp := alleleval + rnd(1,2);  { Add one or two }
   case temp of
     -1: mutation := temp;
      0: mutation := temp;
      1: mutation := temp;
      2: mutation := -1;
      3: mutation := 0;
     end {case}
  end else
   mutation := alleleval;     { No change }
end;

procedure crossover(var parent1, parent2, child1, child2:chromosome;
                    var lchrom, ncross, nmutation, jcross:integer;
                    var pcross, pmutation:real);
{ Cross 2 parent strings, place in 2 child strings }
var j:integer;
begin
 if flip(pcross) then begin     { Do crossover with p(cross) }
   jcross := rnd(1,lchrom-1);     { Cross between 1 and l-1 }
   ncross := ncross + 1;          { Increment crossover counter }
  end else                      { Otherwise set cross site to force mutation }
   jcross := lchrom;
 { 1st exchange, 1 to 1 and 2 to 2 }
 for j := 1 to jcross do begin
   child1[j] := mutation(parent1[j], pmutation, nmutation);
   child2[j] := mutation(parent2[j], pmutation, nmutation);
  end;
 { 2nd exchange, 1 to 2 and 2 to 1 ]
 if jcross<>lchrom then   { Skip if cross site is lchrom--no crossover }
  for j := jcross+1 to lchrom do begin
    child1[j] := mutation(parent2[j], pmutation, nmutation);
    child2[j] := mutation(parent1[j], pmutation, nmutation);
   end;
end;

function mapdominance(allele1,allele2:allele):allele;
{ dominance map using > relation among (-1,0,1) }
begin
 if (allele1 >= allele2) then mapdominance := abs(allele1)
  else mapdominance := abs(allele2)
end;

procedure dominance(var lchrom:integer;
                    var homologous:chrompack;
                    var expressed:chromosome );
{ express dominance - homologous pair --> single chrom }
var j:integer;
begin
  for j:=1 to lchrom do
    expressed[j]:=mapdominance(homologous[1,j],homologous[2,j])
end;