uea.pas

这是一道很基本的程序

{ interface-based implementation of
  Dan Taylor's ([e-mail])
  Evolutionary TSP Algorithm demo program
Modified: September 2002
  by Nikolai Shokhirev ([e-mail])
  http://www.chem.arizona.edu/~shokhirn/index.html) }
{ Implementation of all interfaces }
unit uEA;

interface

uses
  uUtilsEA, uIEA, uITSP, Classes;

type

  TIndividual = class(TInterfacedObject, IIndividual)
  private
    // The internally stored fitness value
    fFitness: TFloat;
    procedure SetFitness(const Value: TFloat);
    function GetFitness: TFloat;
  public
    property Fitness : TFloat read GetFitness write SetFitness;
  end;

  TTSPIndividual = class(TIndividual, ITSPIndividual)
  private
    // The route we travel
    fRouteArray : ArrayInt;
    function GetRouteArray(I: Integer): Integer;
    procedure SetRouteArray(I: Integer; const Value: Integer);
    procedure SetSteps(const Value: Integer);
    function GetSteps: Integer;
  public
    // Constructor, called with initial route size
    constructor Create(Size : TInt); reintroduce;
    destructor Destroy; override;
    property RouteArray[I : Integer] : Integer read GetRouteArray write SetRouteArray;
    // The number of steps on the route
    property Steps : Integer read GetSteps write SetSteps;
    property Fitness : TFloat read GetFitness write SetFitness;
  end;

  TTSPCreator = class(TInterfacedObject, ITSPCreator)
  private
    // The Control component we are associated with
    fController: ITSPController;
    function GetController: ITSPController;
    procedure SetController(const Value: ITSPController);
  public
    // Function to create a random individual
    function CreateIndividual : IIndividual;
    property Controller : ITSPController read GetController write SetController;
  end;

  TKillerPercentage = class(TInterfacedObject, IKillerPercentage)
  private
    fPer: TFloat;
    procedure SetPercentage(const Value: TFloat);
    function GetPercentage: TFloat;
  public
    function Kill(Pop : IPopulation): Integer;
    // Percentage of population to be killed
    property Percentage: TFloat read GetPercentage write SetPercentage;
  end;

  TParentSelectorTournament = class(TInterfacedObject, IParentSelector)
  public
    function SelectParent(Population: IPopulation): IIndividual;
  end;

  TTSPBreederCrossover = class(TInterfacedObject, IBreeder)
  public
    function BreedOffspring(PSelector: IParentSelector; Pop: IPopulation): IIndividual;
  end;

  TTSPMutator = class(TInterfacedObject, ITSPMutator)
  private
    fTrans: TFloat;
    fInv: TFloat;
    procedure SetInv(const Value: TFloat);
    procedure SetTrans(const Value: TFloat);
    function GetInv: TFloat;
    function GetTrans: TFloat;
  public
    procedure Mutate(Individual: IIndividual);
    published
    // Probability of doing a transposition
    property Transposition: TFloat read GetTrans write SetTrans;
    // Probability of doing an inversion
    property Inversion: TFloat read GetInv write SetInv;
  end;

  TTSPExaminer = class(TInterfacedObject, ITSPExaminer)
  private
    // The Control component we are associated with
    fController: ITSPController;
    function GetController: ITSPController;
    procedure SetController(const Value: ITSPController);
  public
    // Returns the fitness of an individual as a real number where 0 => best
    function GetFitness(Individual : IIndividual) : TFloat;
    property Controller : ITSPController read GetController write SetController;
  end;

  TPopulation = class(TInterfacedObject, IPopulation)
  private    
    // The population
    fPop : TInterfaceList;
    // Worker for breeding
    fBreeder: IBreeder;
    // Worker for killing
    fKiller: IKiller;
    // Worker for parent selection
    fParentSelector: IParentSelector;
    // Worker for mutation
    fMutator: IMutator;
    // Worker for initial creation
    fCreator: ICreator;
    // Worker for fitness calculation
    fExaminer: IExaminer;
    // On Change event
    FOnChange: TNotifyEvent;
    procedure Change;
    // Getters and Setters
    function GetIndividual(I: Integer): IIndividual;
    function GetCount: Integer;
    function GetBreeder: IBreeder;
    function GetCreator: ICreator;
    function GetExaminer: IExaminer;
    function GetKiller: IKiller;
    function GetMutator: IMutator;
    function GetOnChange: TNotifyEvent;
    function GetParentSelector: IParentSelector;
    procedure SetBreeder(const Value: IBreeder);
    procedure SetCreator(const Value: ICreator);
    procedure SetExaminer(const Value: IExaminer);
    procedure SetKiller(const Value: IKiller);
    procedure SetMutator(const Value: IMutator);
    procedure SetOnChange(const Value: TNotifyEvent);
    procedure SetParentSelector(const Value: IParentSelector);
    // not interfaced
    procedure DanQuickSort(SortList: TInterfaceList; L, R: Integer; SCompare: TInterfaceCompare);
    procedure Sort(Compare: TInterfaceCompare);
  protected
    // Comparison function for Sort()
    function CompareIndividuals(I1, I2: IIndividual): Integer;
    // Sort the population
    procedure SortPopulation;
  public
    // The constructor
    constructor Create;
    // The destructor
    destructor Destroy; override;
    // Adds an individual to the population
    procedure Add(New : IIndividual);
    // Deletes an individual from the population
    procedure Delete(I : Integer);
    // Runs a single generation
    procedure Generation;
    // Initialise the population
    procedure Initialise(Size : Integer);
    // Clear ourselves out
    procedure Clear;
    // Get the fitness of an individual
    function FitnessOf(I : Integer) : TFloat;
    // Access to the population members
    property Pop[I : Integer] : IIndividual read GetIndividual; default;
    // The size of the population
    property Count : Integer read GetCount;
    property ParentSelector : IParentSelector read GetParentSelector write SetParentSelector;
    property Breeder : IBreeder read GetBreeder write SetBreeder;
    property Killer : IKiller read GetKiller write SetKiller;
    property Mutator : IMutator read GetMutator write SetMutator;
    property Creator : ICreator read GetCreator write SetCreator;
    property Examiner : IExaminer read GetExaminer write SetExaminer;
    // An event
    property OnChange : TNotifyEvent read GetOnChange write SetOnChange;
  end;

  TTSPController = class(TInterfacedObject, ITSPController)
  private
    fXmin, fXmax, fYmin, fYmax: TFloat;
    {  The array of 'cities' }
    fCities : array of TPoint2D;
    {  The number of 'cities' }
    fCityCount: Integer;
    {  Getters... }
    function GetCity(I: Integer): TPoint2D;
    function GetCityCount: Integer;
    function GetXmax: TFloat;
    function GetXmin: TFloat;
    function GetYmax: TFloat;
    function GetYmin: TFloat;
    {  Setters... }
    procedure SetCityCount(const Value: Integer);
    procedure SetXmax(const Value: TFloat);
    procedure SetXmin(const Value: TFloat);
    procedure SetYmax(const Value: TFloat);
    procedure SetYmin(const Value: TFloat);
  public
    {  The constructor }
    constructor Create;
    {  The destructor }
    destructor Destroy; override;
    {  Get the distance between two cities }
    function DistanceBetween(C1, C2 : Integer) : TFloat;
    {  Places the cities at random points }
    procedure RandomCities;
    { Area limits }
    property Xmin: TFloat read GetXmin write SetXmin;
    property Xmax: TFloat read GetXmax write SetXmax;
    property Ymin: TFloat read GetYmin write SetYmin;
    property Ymax: TFloat read GetYmax write SetYmax;
    {  Properties... }
    property CityCount : Integer read GetCityCount write SetCityCount;
    {  Access to the cities array }
    property Cities[I : Integer] : TPoint2D read GetCity;
  end;

implementation

uses
  Math;

{ TIndividual }

function TIndividual.GetFitness: TFloat;
begin
  result := fFitness;
end;

procedure TIndividual.SetFitness(const Value: TFloat);
begin
  fFitness := Value;
end;

{ TTSPIndividual }

constructor TTSPIndividual.Create(Size: TInt);
begin
  Inherited Create;
  SetLength(fRouteArray, Size);
//  fSteps := Size;
end;

destructor TTSPIndividual.Destroy;
begin
  SetLength(fRouteArray, 0);
  inherited;
end;

function TTSPIndividual.GetRouteArray(I: Integer): Integer;
begin
  result := fRouteArray[I];
end;

function TTSPIndividual.GetSteps: Integer;
begin
  result := Length(fRouteArray);
end;

procedure TTSPIndividual.SetSteps(const Value: Integer);
begin
  SetLength(fRouteArray, Value);
end;

procedure TTSPIndividual.SetRouteArray(I: Integer; const Value: Integer);
begin
  fRouteArray[I] := Value;
end;

{ TTSPCreator }

function TTSPCreator.CreateIndividual: IIndividual;
var
  New: ITSPIndividual;
  i, j, Top, Temp  : Integer;
begin
  // Get the number of cities
  Top := fController.CityCount;
  // Create the new individual
  New := TTSPIndividual.Create(Top);
  // Initialise it with a sequential route
  for i := 0 to Top - 1 do
    New.RouteArray[i] := i;
  // Shuffle the route
  for i := Top - 1 downto 1 do
  begin
    j := Random(i);
    Temp := New.RouteArray[j];
    New.RouteArray[j] := New.RouteArray[i];
    New.RouteArray[i] := Temp;
  end;
  result := New;
end;

function TTSPCreator.GetController: ITSPController;
begin
  result := fController;
end;

procedure TTSPCreator.SetController(const Value: ITSPController);
begin
  fController := Value;
end;

{ TKillerPercentage }

function TKillerPercentage.GetPercentage: TFloat;
begin
  result := fPer;
end;

function TKillerPercentage.Kill(Pop: IPopulation): Integer;
var
  KillCount, i : Integer;
begin
  // Work out the number we have to kill
  KillCount := Floor(Pop.Count * (fPer / 100));
  // Delete the worst individuals - assuming the population is sorted
  for i := 1 to KillCount do
    Pop.Delete(Pop.Count - 1);
  // Return the number killed
  Result := KillCount;
end;

procedure TKillerPercentage.SetPercentage(const Value: TFloat);
begin
  fPer := Value;
end;

{ TParentSelectorTournament }

function TParentSelectorTournament.SelectParent(
  Population: IPopulation): IIndividual;
var
  i1, i2  : Integer;
begin
  // Select a random individual
  i1 := Random(Population.Count);
  // Select a *different* random individual
  repeat
    i2 := Random(Population.Count);
  until i1 <> i2;
  // Hold the tournament and return the fittest of the two
  if Population.FitnessOf(i1) < Population.FitnessOf(i2) then
    Result := Population[i1]
  else
    Result := Population[i2];
end;

{ TTSPBreederCrossover }

function TTSPBreederCrossover.BreedOffspring(PSelector: IParentSelector;
  Pop: IPopulation): IIndividual;
var
  Child, Mom, Dad, Parent1, Parent2 : ITSPIndividual;
  i, j, p : Integer;

  function AlreadyAssigned(City, x : Integer) : Boolean;
  var
    y : Integer;
    Found : Boolean;
  begin  
    Found := False;    
    for y := 0 to x - 1 do
    begin
      if Child.RouteArray[y] = City then      
      begin        
        Found := True;        
        Break;      
      end;    
    end;    
    Result := Found;  
  end;
  
begin  
  // Select a some parents...  
  Mom := PSelector.SelectParent(Pop) as ITSPIndividual;
  Dad := PSelector.SelectParent(Pop) as ITSPIndividual;
  // Create a child
  Child := TTSPIndividual.Create(Mom.Steps);
  // Copy the route from parents to child  
  for i := 0 to Child.Steps - 1 do  
  begin    
    // Choose a parent at random    
    p := Random(2);
    if p = 0 then    
    begin      
      Parent1 := Mom;
      Parent2 := Dad;
    end else    
    begin      
      Parent1 := Dad;      
      Parent2 := Mom;
    end;    
    if not AlreadyAssigned(Parent1.RouteArray[i], i) then    
    begin      
      // Use city from Parent 1 unless used already      
      Child.RouteArray[i] := Parent1.RouteArray[i];    
    end else 
      if not AlreadyAssigned(Parent2.RouteArray[i], i) then    
      begin      
        // Otherwise use city from Parent 2 unless used already      
        Child.RouteArray[i] := Parent2.RouteArray[i];    
      end else    
      begin      
        // If both assigned already then use a random city      
        repeat        
          j := Random(Child.Steps);      
        until not AlreadyAssigned(j, i);      
        Child.RouteArray[i] := j;    
      end;