öÎíµÃÎÔ°µÄ²©¿Í

const
  Popsize = 500;
  Maximization = 1;
  Minimization = 2;
  Cmax = 100;
  Cmin = 0;
  Length1 = 10;
  Chroml = Length1 + Length2;//×ܳ¤¶È
  Length2 = 10;
var
  functionMode :Integer = Maximization;
  PopSize: Integer = 80;
  MaxGenera: Integer = 200;
  Pc: Double = 0.6;
  Pm: Double = 0.001;
  generation: Integer;
  Best_index: Integer;
  Worst_index: Integer;
 
Type
  individual = record
    chrom: arry of Char;//[Chromlength + 1]
    Value: Double;
    Fitness: Double;
  end;
 
Var
  Bestindividual: individual;
  Worstindividual: individual;
  Currentbest: individual;
  Population: array of individual;//[Popsize]
 
////////////////////////////////////////////////
  Procedure main;//Ö÷³ÌÐòÄ£¿é
  begin
    setlength(chrom, Chromlength + 1);
    setlength(Population, PopSize);
    generation := 0;
    generateInitialPopulation;//¹ý³Ìº¯Êý
    EvaluatePopulation;//¹ý³Ìº¯Êý
    While genaeration < MaxGeneration do
    begin
      Inc(genaeration);
      GenerateNextPopulation;//¹ý³Ìº¯Êý
      EvaluatePopulation;
      PerformEvolution;
      OutputTextReport;
    end;
  end;

//////////////////////////////////

  Procedure GeneratelnitialPopulation;
  var
    I,J: Integer;
    tmv: Integer;
    tms: Char;
  begin
    Randomize;
    for I := 0 to PopSize do
    begin
      for  J := 0 to Chromlength do
      begin
 tmv := Random(10);
 if tmv < 5 then
   tms := '0'
        else tms := '1';
        Population[i].chrom[j] := tms;
      end;
      Population[i].chrom[Chromlength] := '\0'
    end;
  end;

/////////////////////////////////////////
  Procedure GenerateNextPopulation;
  begin
    SelectionOperator;
    CrossoverOperator;
    MutationOperator;
  end;

//////////////////////////
  Procedure EvaluatePopulation;
  begin
    CalculateObjectValue;
    CalculateFitnessValue;
    FindBestAndWorstIndividual;
  end;

////////////////////////////////
  function DecodeChromosome(Strings: char; point, length: Integer): long;
  var
    I: Integer;
    decimal: long;// = 0L;
    Pointer: Char;
  begin
    decimal := #0;
    for i := 0 to length do
    begin
      Pointer := Strings + Point;
      Pointer ++;
      decimal := decimal + (pointer -'0')<<(length - 1 - i);
    end;
    result := decimal;
  end;

////////////////////////////////
  Pocedure CalculateObjectValue;
  var
    I: Integer;
    temp1, temp2: Long;
    x1, x2: Double;
  begin
    for I := 0 to PopSize do
    begin
      temp1 := DecodeChromosome(Population[i].chrom, 0, length1);
      temp2 := Decodechromosome(Population[i].chrom, length1, length2);
      x1 := 4.096 * temp1 / 1023 - 2.048;
      x2 := 4.096 * temp2 / 1023 - 2.048;
      Population[i].value := 100*(x1 * x1 - x2) * (x1 * x1 - x2) + (1 - x1) * (1 - x1);
    end;
  end;

////////////////////////////////////
  Procedure CalculateFitnessValue;
  var
    I: Integer;
    temp: Double;
  begin
    for I := 0 to PopSize do
    begin
      if functionMode = Maximization then
      begin
        if Population[i].value + Cmin > 0 then
   temp := Cmin + Population[i].value;
        else temp := 0;
      end else
      if FunctionMode = Minimization then //minimization;
      begin
        if Population[i].value < Cmax then
   temp := Cmax - Population[i].value
        else temp := 0;
      end;
      Population[i].fitness := temp;
    end;
  end;

////////////////////////////
  Procedure FindBestAndWorstIndividual;
  var
    I: Integer;
    sum: double;
  begin
    sum := 0;
    bestindividual := Population[0];
    worstindividual := Population[0];
    for I := 0 to PopSize do
    begin
      if Population[i].fitness > bestindividual.fitness then
      begin
        bestindividual := Population[i];
        best_Index := i;
      end else
      if Population[i].fitness < worstindividual.fitness then
      begin
        worstindividual := Population[i];
        worst_Index := i;
      end;
      sum := sum + Population[i].fitness;
    end;
    if generation = 0 then
      currentbest := bestindividual
    else
    if bestindividual.fitness > currentbest.fitness then
      currentbest := bestindividual;
  end;

////////////////////////////////////////
  Procedure PerformEvolution;
  begin
    if bestindividual.fitness > currentbest.fitness then
      currentbest := Population[best_index]
    else Population[worst_index] := currentbest;
  end;

///////////////////////////////
  Procedure SelectionOperator;
  var
    I, index: Integer;
    p, sum: Double;
    cfitness: Double;
    newPopulation: array of Individual;//[PopSize]
  begin
    sum := 0;
    setLength(newPopulation, PopSize);
    for I := 0 to PopSize do
      sum := sum + Population[i].fitness;
    for I := 0 to PopSize do
      cfitness[i] := Population[i].fitness / sum;
    for I := 1 to PopSize do
      cfitness[i] := cfitness[i - 1] + cfitness[i];
    for I := 0 to PopSize do
    begin
      P := randome mod 1000 / 1000;//Ëæ»ú0-1Ö®¼äµÄСÊý
      index := 0;
      While P > cfitness[index] do
        Index := Index + 1;
      newpopulation[i] := Population[index];
    end;
    for i := 0 to PopSize do
      Population[i] := newpopulation[i];
  end;

///////////////////////
  Procedure CrossoverOperator;//½»²æ¹ý³Ì
  var
    I, J: Integer;
    index: array of Integer;
    Point, temp: Integer;
    P: double;
    ch: Char;
  begin
    Setlength(Index, PopSize);
    for I := 0 to PopSize do
      Index[i] := i;
    for I := 0 to PopSize do
    begin
      Point := random(PopSize - i);
      temp := Index[i];
      index[i] := index[point + i];
      index[Point + i] := temp;
    end;
    for I := 0 PopSize do
    begin
      p := rand mod 1000 / 1000;
      if P < Pc then
      begin
        Point := random(chromlength - 1) + 1;
        for J := 0 to chromlength do
        begin
          ch := Population[index[i]].chrom[j];
          Population[index[i].chrom[j] := Population[index[i + 1]].chrom[j];
          Population[index[i + 1]].chrom[j] := ch;
        end;
      end;
    end;
  end;

///////////////////////////////
  Procedure MutationOperator;
  var
    I, J: Integer;
    P: Double;
  begin
    for i := 0 to PopSize do
    begin
      for J := 0 to Chromlength do
      begin
        P := rand mod 1000 / 1000;
        if P < Pm then
        begin
   if Population[i].chrom[j] = 0 then
            Population[i].chrom[j] := '1'
          else Population[i].chrom[j] := '0';
        end;
      end;
    end;
  end;

//////////////////////////////////
  Procedure OutputTextReport;
  var
    I: Integer;
    sum: Double;
    average: Double;
    ss: Tmemo;
   
  begin
    sum := 0;
    for i := 0 to PopSize do
      sum := sum + Population[i].value;
    average := sum / PopSize;
    ss.lines.add(format('gen = %d, avg=%f, best=%f,'[generation, average, currentbest.value]));
   
    ss.lines.add('chromosome=');
    for i := 0 to chromlength do
      ss.lines.add(format('%c', currentbest.chrom[i]));
    ss.lines.add(#13#10);
  end;