ga tsp.txt

tsp遗传算法源代码

    // 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;  
    end;  
  // Return the child
  Result := Child;
  end;

{ TTSPMutator }

function TTSPMutator.GetInv: TFloat;
begin
  result := fInv;
end;

function TTSPMutator.GetTrans: TFloat;
begin
  result := fTrans;
end;

procedure TTSPMutator.Mutate(Individual: IIndividual);
var
  P: Double;  
  i, j, t       : Integer;  Start, Finish : Integer;
begin  
  with Individual as ITSPIndividual do
  begin    
    // Should we do an inversion?    
    P := Random * 100;    
    if P < FTrans then    
    begin      
      // Do an inversion (i.e. swap two cities at random)      
      // Choose first city
      i := Random(Steps);      
      // Choose a second city      
      repeat        
        j := Random(Steps);      
      until i <> j;      
      // Swap them over
      t := RouteArray[i];
      RouteArray[i] := RouteArray[j];
      RouteArray[j] := t;
    end;
    // Should we do a transposition?
    P := Random * 100;
    if P < FInv then
    begin
      // Do a transposition (i.e. reverse a sub-route)
      // Choose random start and finish points
      Start := Random(Steps - 1);
      Finish := Start + Random(Steps - Start);
      // Reverse the sub-route
      for i := 0 to Floor((Finish - Start) / 2) do
      begin
        t := RouteArray[Start + i];
        RouteArray[Start + i] := RouteArray[Finish - i];
        RouteArray[Finish - i] := t;
      end;
    end;
  end;
end;

procedure TTSPMutator.SetInv(const Value: TFloat);
begin
  fInv := Value;
end;

procedure TTSPMutator.SetTrans(const Value: TFloat);
begin
  fTrans := Value;
end;

{ TTSPExaminer }

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

function TTSPExaminer.GetFitness(Individual: IIndividual): TFloat;
var
  i        : Integer;
  Distance : Double;
  Indi     : ITSPIndividual;
begin
  Indi := Individual as ITSPIndividual;
  Distance := 0;
  for i := 0 to Indi.Steps - 2 do
  begin
    Distance := Distance + fController.DistanceBetween(Indi.RouteArray[i], Indi.RouteArray[i + 1]);
  end;
  Distance := Distance + fController.DistanceBetween(Indi.RouteArray[Indi.Steps - 1], Indi.RouteArray[0]);
  Result := Distance;
end;

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

{ TPopulation }

constructor TPopulation.Create;
begin
  inherited;
  fPop := TInterfaceList.Create;
end;

destructor TPopulation.Destroy;
begin
  fPop.Free;
  inherited;
end;

procedure TPopulation.Add(New: IIndividual);
begin
  fPop.Add(New);
end;

procedure TPopulation.Clear;
begin
  fPop.Clear;
end;

function TPopulation.CompareIndividuals(I1, I2: IIndividual): Integer;
var
  A, B, D : TFloat;
begin
  // Get the difference between the two individuals (real number)
  A := I1.Fitness;
  B := I2.Fitness;

  D := A - B;

  // Quickest way to convert that to an integer is...
  if D > 0 then
    Result := 1
  else if D < 0 then
    Result := -1
  else
    Result := 0;
end;

procedure TPopulation.Delete(I: Integer);
begin
  fPop.Delete(I);
end;

function TPopulation.FitnessOf(I: Integer): TFloat;
begin
  result := Pop[I].Fitness;
end;

procedure TPopulation.Change;
begin
  if Assigned(fOnChange) then
    FOnChange(Self);
end;

procedure TPopulation.Generation;
var
  Replace, i : Integer;
  New        : IIndividual;
begin
  // Kill some of the population
  Replace := fKiller.Kill(Self);

  for i := 1 to Replace do
  begin
    // Breed a new individual
    New := fBreeder.BreedOffspring(fParentSelector, Self);
    // Perform some mutation on the individual
    FMutator.Mutate(New);
    // Get the fitness of the new individual
    New.Fitness := fExaminer.GetFitness(New);
    // Add it to the population
    Add(New);
  end;
  // Sort the population into fitness order where first <==> best
  SortPopulation;

  Change;
end;

function TPopulation.GetBreeder: IBreeder;
begin
  result := fBreeder;
end;

function TPopulation.GetCount: Integer;
begin
  result := fPop.Count;
end;

function TPopulation.GetCreator: ICreator;
begin
  result := fCreator;
end;

function TPopulation.GetExaminer: IExaminer;
begin
  result := fExaminer;
end;

function TPopulation.GetIndividual(I: Integer): IIndividual;
begin
  result := (fPop[I] as IIndividual);
end;

function TPopulation.GetKiller: IKiller;
begin
  result := fKiller;
end;

function TPopulation.GetMutator: IMutator;
begin
  result := fMutator;
end;

function TPopulation.GetOnChange: TNotifyEvent;
begin
  result := fOnChange;
end;

function TPopulation.GetParentSelector: IParentSelector;
begin
  result := fParentSelector;
end;

procedure TPopulation.Initialise(Size: Integer);
var
  i: Integer;
  New: IIndividual;
begin
  // Clear out the old stuff
  Clear;
  // Set the capacity first to save about 12 nanoseconds ;o)
  fPop.Capacity := Size;
  // Create the appropriate number of individuals
  for i := 1 to Size do
  begin
    // Create the individual
    New := fCreator.CreateIndividual;
    // Get the fitness of the new individual
    New.Fitness := fExaminer.GetFitness(New);
    // Add to the population
    Add(New);
  end;
  SortPopulation;
  Change;
end;

procedure TPopulation.SetBreeder(const Value: IBreeder);
begin
  fBreeder := Value;
end;

procedure TPopulation.SetCreator(const Value: ICreator);
begin
  fCreator := Value;
end;

procedure TPopulation.SetExaminer(const Value: IExaminer);
begin
  fExaminer := Value;
end;

procedure TPopulation.SetKiller(const Value: IKiller);
begin
  fKiller := Value;
end;

procedure TPopulation.SetMutator(const Value: IMutator);
begin
  fMutator := Value;
end;

procedure TPopulation.SetOnChange(const Value: TNotifyEvent);
begin
  fOnChange := Value;
end;

procedure TPopulation.SetParentSelector(const Value: IParentSelector);
begin
  fParentSelector := Value;
end;

procedure TPopulation.DanQuickSort(SortList: TInterfaceList; L, R: Integer;
  SCompare: TInterfaceCompare);
var
  I, J: Integer;
  P: IIndividual;
begin
  repeat
    I := L;
    J := R;
    P := SortList.Items[(L + R) div 2] as IIndividual;
    repeat
      while SCompare(SortList.Items[I] as IIndividual, P) < 0 do
        Inc(I);
      while SCompare(SortList.Items[J] as IIndividual, P) > 0 do
        Dec(J);
      if I <= J then
      begin
        SortList.Exchange(I, J);
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      DanQuickSort(SortList, L, J, SCompare);
    L := I;
  until I >= R;
end;

procedure TPopulation.Sort(Compare: TInterfaceCompare);
begin
  if Assigned(fPop) and (Count > 0) then
    DanQuickSort(fPop, 0, Count - 1, Compare);
end;

procedure TPopulation.SortPopulation;
begin
  Sort(self.CompareIndividuals);
end;

{ TTSPController }

constructor TTSPController.Create;
begin
  inherited;
end;

destructor TTSPController.Destroy;
begin
  SetLength(FCities, 0);
  inherited;
end;

{  Standard euclidian distance between two 2D vectors...  }
function TTSPController.DistanceBetween(C1, C2: Integer): TFloat;
begin
  Result := Sqrt(sqr(Cities[C1].X - Cities[C2].X)
           +     sqr(Cities[C1].Y - Cities[C2].Y));
end;


function TTSPController.GetCity(I: Integer): TPoint2D;
begin
  result := fCities[I];
end;

function TTSPController.GetCityCount: Integer;
begin
  result := fCityCount;
end;