gabase.pas

遗传算法优化程序

unit GABase;

{Developed by Shu Jun, 2000/6/24, PMI, NCEPU}
{TGABase is a abstract class. You must Derivate a sub_class from it. You must
override abstract function calculateFitness. By the way, this class can only
get minimum solution}  

interface
uses
  Dialogs,Sysutils;

type
  CIndividual = record
    IntegerSection: array of integer;
    FloatSection: array of double;
    IsSurvival: boolean;//在选择中存活的个体, 不被交叉和变异
    IsProtected: boolean;//受保护的个体不被且不参与交叉和变异，
                        //用于专家控制和优化群体复制.
    Fitness: double;
  end;

  CISectionLimit = record
    UpperLimit: integer;
    LowerLimit: integer;
  end;

  CFSectionLimit = record
    UpperLimit: double;
    LowerLimit: double;
  end;

  TGABase = class(TObject)
  private
    MaxJudge       :Boolean;        //True—最大值，False—最小值
    Temp_Population: array of CIndividual;
    ISectionLimit  : array of CISectionLimit;
    FSectionLimit  : array of CFSectionLimit;
    IntegerNum     : integer;
    FloatNum       : integer;
    MutationRatio  : double;
    CrossOverRatio : double;
    Generations    : integer;
    NSurvivors     : integer;
    CurrentGen     : integer;
    procedure SetRandom;
    function RandVal(ALow, AUp: integer): integer; overload;
    function RandVal(ALow, AUp: double): double; overload;
    function FindCanCopyed: integer;
    procedure SelectFace2Face;         //遗传
    procedure EquablyCrossOver;        //交叉
    procedure Mutation; virtual;       //变异
  public
    Population: array of CIndividual;
    constructor Create;
    destructor Destroy;override;
    procedure IniData(AINum, AFNum: integer; AIUp, AILow: array of integer;
      AFUp, AFLow: array of double);
    procedure IniParameter(Max:Boolean = False; AGens: integer = 200; APop: integer = 60; AMutionR: double = 0.01; ACrossOverR: double = 0.5);
    procedure Calculate(ACurGen: integer); virtual;
    procedure CopyData(var ADes: CIndividual; ASrc: CIndividual);
  protected
    PopSize: integer;
    procedure CalculateFitness; virtual; abstract;
  end;
  
implementation

{ TGABase }
uses
  math;

constructor TGABase.Create;
begin
  SetRandom();
end;

destructor TGABase.Destroy;
begin
  Population := nil;
  Temp_Population := nil;
end;

procedure TGABase.IniData(AINum, AFNum: integer;
  AIUp, AILow: array of integer; AFUp, AFLow: array of double);
var
  I, J: integer;
begin
  SetRandom();
  IntegerNum := AINum;
  FloatNum := AFNum;
  SetLength(ISectionLimit, AINum);
  SetLength(FSectionLimit, AFNum);
  for I := 0 to AINum - 1 do
  begin
    ISectionLimit[I].UpperLimit := AIUp[I];
    ISectionLimit[I].LowerLimit := AILow[I];
  end;//for                    
  for I := 0 to AFNum - 1 do
  begin
    FSectionLimit[I].UpperLimit := AFUp[I];
    FSectionLimit[I].LowerLimit := AFLow[I];
  end;
  SetLength(Population, PopSize + 1);
  SetLength(Temp_Population, PopSize + 1);
  for I := 0 to PopSize do
  begin
    SetLength(Population[I].IntegerSection, AINum);
    SetLength(Population[I].FloatSection, AFNum);
    SetLength(Temp_Population[I].IntegerSection, AINum);
    SetLength(Temp_Population[I].FloatSection, AFNum);
    Population[I].IsProtected := false;             
    for J := 0 to AINum - 1 do
      Population[I].IntegerSection[J] := RandVal(ISectionLimit[J].LowerLimit,
        ISectionLimit[J].UpperLimit);
    for J := 0 to AFNum - 1 do
      Population[I].FloatSection[J] := RandVal(FSectionLimit[J].LowerLimit,
        FSectionLimit[J].UpperLimit);
  end;//for
  Population[PopSize].Fitness := 10E100;
end;

procedure TGABase.IniParameter(Max:Boolean;AGens, APop: integer; AMutionR,
  ACrossOverR: double);
begin
  MaxJudge:=Max;
  Generations := AGens;
  PopSize := APop;
  MutationRatio := AMutionR;
  CrossOverRatio := ACrossOverR;
end;

procedure TGABase.SetRandom;
begin
  RandSeed := 0;
end;

function TGABase.RandVal(ALow, AUp: integer): integer;
var
  Num: integer;
begin
  Num := AUp - ALow;
  result := ALow + random(Num + 1);
end;

function TGABase.RandVal(ALow, AUp: double): double;
var
  Temp: double;
begin
  Temp := AUp - ALow;
  result := ALow + random * Temp;
end;

procedure TGABase.SelectFace2Face;
var
  I, FirstMem, SecondMem, Winner: integer;
begin
  //如果最优解失去,拷贝一份
  I := 0;
  while (I < PopSize) and ((Population[I].IsProtected = true)
    or (Population[I].Fitness <> Population[PopSize].Fitness)) do
    I := I + 1;
  if I = PopSize then
  begin
    FirstMem := FindCanCopyed;
    CopyData(Population[FirstMem], Population[PopSize])
  end;
  //选择好个体进入Temp_Population, 保留的最好个体与受保护个体不参与竞争
  for I := 0 to PopSize - 1 do
  begin
    FirstMem := Random(PopSize);
    while Population[FirstMem].IsProtected = true do
      FirstMem := Random(PopSize);
    SecondMem := Random(PopSize);
    while Population[SecondMem].IsProtected = true do
      SecondMem := Random(PopSize);

    if MaxJudge then     //求最大值
    begin
      if Population[FirstMem].Fitness>Population[SecondMem].Fitness then
        Winner :=FirstMem
      else
        Winner :=SecondMem;
    end
    else begin           //求最小值
       if Population[FirstMem].Fitness<Population[SecondMem].Fitness then
        Winner :=FirstMem
      else
        Winner :=SecondMem;
    end;

    CopyData(Temp_Population[I], Population[Winner]);
  end;//for

  //将Temp_Population考入Population,保证Population中受保护的个体不被覆盖
  for I := 0 to PopSize - 1 do
  begin
    if Population[I].IsProtected = false then
    begin
      CopyData(Population[I], Temp_Population[I]);
    end;//if
  end;//for

  NSurvivors := 0;
  for I := 0 to PopSize - 1 do
    if CrossOverRatio < Random then
    begin
      Population[I].IsSurvival := true;
      NSurvivors := NSurvivors + 1;
    end
    else
      Population[I].IsSurvival := false;
    Population[Popsize].IsSurvival := true;
end;

procedure TGABase.EquablyCrossOver;
var
  I, J, a, b, POne, PTwo, Count: integer;
begin
{  for I := 0 to PopSize - 1 do
  begin
    if random(2) = 0 then
      Population[I].IsSurvival := true
    else
      Population[I].IsSurvival := false;
  end;}
  for I := 0 to PopSize - 1 do
  begin
    POne := 0;
    PTwo := 0;
    if Population[I].IsSurvival = false then
    begin
      a := random(NSurvivors + 1);
      b := random(NSurvivors + 1);
      Count := 0;
      for J := 0 to PopSize - 1 do
      begin
        if (Population[J].IsSurvival = true)
          and (Population[J].IsProtected = false) then
          begin
            Count := Count + 1;
            if Count = a then POne := J;
            if Count = b then PTwo := J;
          end;//if
      end;//for

      for J := 0 to IntegerNum - 1 do
      begin
        if random(2) = 0 then
          Population[I].IntegerSection[J] := Population[POne].IntegerSection[J]
        else
          Population[I].IntegerSection[J] := Population[PTwo].IntegerSection[J];
      end;//for

      for J := 0 to FloatNum - 1 do
      begin
        if random(2) = 0 then
          Population[I].FloatSection[J] := Population[POne].FloatSection[J]
        else
          Population[I].FloatSection[J] := Population[PTwo].FloatSection[J];
      end;//for
    end;//if
  end;//for
end;

procedure TGABase.Mutation;
var
  I, MutationNum, Member, Point: integer;
begin
  MutationNum := Round(PopSize * (IntegerNum + FloatNum) * MutationRatio);
  I := 0;
  while I < MutationNum do
  begin
    Member := Random(PopSize);
    if Population[Member].IsProtected <> true then
    begin
      if IntegerNum > 0 then
      begin
        Point := Random(IntegerNum);
        if Random(2) = 0 then
        begin
          Population[Member].IntegerSection[Point]
             := RandVal(ISectionLimit[Point].LowerLimit,
             Population[Member].IntegerSection[Point]);
        end
        else begin
          Population[Member].IntegerSection[Point]
             := RandVal(Population[Member].IntegerSection[Point],
             ISectionLimit[Point].UpperLimit);
        end;//if
      end;//if
      if FloatNum > 0 then
      begin
        Point := Random(FloatNum);
        if Random(2) = 0 then
        begin
          Population[Member].FloatSection[Point]
             := RandVal(FSectionLimit[Point].LowerLimit,
             Population[Member].FloatSection[Point]);
        end
        else begin
          Population[Member].FloatSection[Point]
             := RandVal(Population[Member].FloatSection[Point],
             FSectionLimit[Point].UpperLimit);
        end;//if
      end;//if
      I := I + 1;
    end;//if
  end;//while
end;

function TGABase.FindCanCopyed: integer;
var
  Member: integer;
begin
    Member := Random(PopSize);
    while Population[Member].IsProtected = true do
      Member := Random(PopSize);
    if Member < PopSize then
      result := Member
    else
      result := -1;
end;

procedure TGABase.Calculate(ACurGen: integer);
begin
  CurrentGen := ACurGen;
  if CurrentGen < Generations then
  begin
    CalculateFitness;
    if CurrentGen = Generations - 1 then exit;
    SelectFace2Face;
    EquablyCrossOver;
    Mutation;
  end;
end;

procedure TGABase.CopyData(var ADes: CIndividual; ASrc: CIndividual);
var
  I: integer;
begin
  for I := 0 to IntegerNum - 1 do
    ADes.IntegerSection[I] := ASrc.IntegerSection[I];
  for I := 0 to FloatNum - 1 do
    ADes.FloatSection[I] := ASrc.FloatSection[I];
  ADes.IsSurvival := ASrc.IsSurvival;
  ADes.IsProtected := ASrc.IsProtected;
  ADes.Fitness := ASrc.Fitness;
end;

end.