ga tsp.txt

tsp遗传算法源代码

unit fEA_TSP;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Spin, ComCtrls, uIEA, uITSP, uUtilsEA, uDisplayTSP;

type
  TFormGA = class(TForm)
    PanelFit: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    PanelDisp: TPanel;
    Panel5: TPanel;
    Panel6: TPanel;
    Label2: TLabel;
    EditNoCities: TSpinEdit;
    EditPopulationSize: TSpinEdit;
    EditKill: TSpinEdit;
    EditInversion: TSpinEdit;
    EditTransposition: TSpinEdit;
    EditGens: TSpinEdit;
    ButtonRun: TButton;
    ButtonStep: TButton;
    ButtonCreateCities: TButton;
    ButtonCreatePop: TButton;
    Bevel1: TBevel;
    Bevel2: TBevel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    StatusBar1: TStatusBar;
    Panel7: TPanel;
    Label1: TLabel;
    ListBox1: TListBox;
    Label7: TLabel;
    Bevel3: TBevel;
    procedure FormCreate(Sender: TObject);
    procedure ButtonCreateCitiesClick(Sender: TObject);
    procedure ButtonCreatePopClick(Sender: TObject);
    procedure ButtonStepClick(Sender: TObject);
    procedure ButtonRunClick(Sender: TObject);
    procedure EditKillChange(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure EditTranspositionChange(Sender: TObject);
    procedure EditInversionChange(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
    fGenerations: integer;
    Display: TTSPDisplay;
    Controller: ITSPController;
    BreederCrossover: IBreeder;
    Examiner: ITSPExaminer;
    Creator: ITSPCreator;
    KillerPercentage: IKillerPercentage;
    Mutator: ITSPMutator;
    Population: IPopulation;
    ParentSelectorTournament: IParentSelector;
    pFit: TPainter0;
    ArrFit: array of TFloat;
    ArrFitLen: integer;
    ArrFitPos: integer;
    BitmapF: TBitmap;
    procedure PopulationChange(Sender: TObject);
    procedure SetGenerations(const Value: integer);
    procedure ClearGraph;
    procedure DrawFit;
    procedure Plot(D: TFloat);
    procedure pFitPaint(Sender: TObject);
    procedure DisplayPaint(Sender: TObject);
  public
    { Public declarations }
    property Generations : integer read fGenerations write SetGenerations;
  end;

var
  FormGA: TFormGA;

implementation

uses
  uEA;

{$R *.DFM}

procedure TFormGA.FormCreate(Sender: TObject);
begin
  Randomize;
  Display := TTSPDisplay.Create(self,PanelDisp);
  Display.SetRanges(0.0,11.0,0.0,11.0,1.0);
  Display.BgColor := clWhite;
  Display.Clear;

  Controller := TTSPController.Create;
  Controller.Xmin := Display.Xmin;
  Controller.Xmax := Display.Xmax;
  Controller.Ymin := Display.Ymin;
  Controller.Ymax := Display.Ymax;

  Display.Controller := Controller;

  Creator := TTSPCreator.Create;
  Creator.Controller := Controller;

  BreederCrossover := TTSPBreederCrossover.Create;

  Examiner := TTSPExaminer.Create;
  Examiner.Controller := Controller;

  KillerPercentage := TKillerPercentage.Create;

  Mutator := TTSPMutator.Create;

  ParentSelectorTournament := TParentSelectorTournament.Create;

  Population := TPopulation.Create;
  Population.Breeder := BreederCrossover;
  Population.Examiner := Examiner;
  Population.Creator := Creator;
  Population.Killer := KillerPercentage;
  Population.Mutator := Mutator;
  Population.ParentSelector := ParentSelectorTournament;
  Population.OnChange := PopulationChange;

  pFit := TPainter0.Create(self,PanelFit);
  pFit.BgColor := clWhite;
  pFit.PenWidth := 3;
  pFit.PenColor := clRed;
  pFit.BrushColor := clRed;
  pFit.Clear;

  BitmapF := TBitmap.Create;
  BitmapF.Canvas.Pen.Color := pFit.PenColor;

  EditKillChange(self);
  EditTranspositionChange(self);
  EditInversionChange(self);
end;

procedure TFormGA.FormDestroy(Sender: TObject);
begin
  BitmapF.Free;
end;

procedure TFormGA.SetGenerations(const Value: integer);
begin
  fGenerations := Value;
  StatusBar1.Panels[0].Text := 'Gens: ' + IntToStr(Value);
end;

procedure TFormGA.ButtonCreateCitiesClick(Sender: TObject);
begin
  Population.Clear;
  Generations := 0;
  ClearGraph;
  Display.Controller.CityCount := EditNoCities.Value;
  Display.DrawMap;
  ButtonCreatePop.Enabled := true;
end;

procedure TFormGA.ButtonCreatePopClick(Sender: TObject);
const
  d = 5;
begin
  Population.Initialise(EditPopulationSize.Value);
  Display.DrawMapWithRoute(Population[0] as ITSPIndividual);
  Display.OnPaint := DisplayPaint;
  Generations := 0;
  ArrFitLen := (pFit.ClientWidth - d) div d;
  SetLength(ArrFit, ArrFitLen);
  ArrFitPos := Low(ArrFit);
  ArrFit[ArrFitPos] := Population.FitnessOf(0);
  pFit.SetRanges(ArrFitPos,ArrFitLen,0.0,ArrFit[ArrFitPos],-1.0);
  DrawFit;
  pFit.OnPaint := pFitPaint;
  ButtonRun.Enabled := true;
  ButtonStep.Enabled := true;
end;

procedure TFormGA.ClearGraph;
begin
  Display.Clear;
  pFit.Clear;
end;

procedure TFormGA.pFitPaint(Sender: TObject);
begin
  DrawFit;
end;

procedure TFormGA.DisplayPaint(Sender: TObject);
begin
  Display.DrawMapWithRoute(Population[0] as ITSPIndividual);
end;

procedure TFormGA.DrawFit;
var
  i: integer;
begin
  with BitmapF do
  begin
    Width := pFit.ClientWidth;
    Height := pFit.ClientHeight;
    Canvas.Brush.Color := clWhite;
    Canvas.FillRect(pFit.ClientRect);
    Canvas.Brush.Color := clRed;
    for i := Low(ArrFit) to ArrFitPos do
    begin
      Canvas.FillRect(pFit.rRect2iRect(i,i+1,0.0, ArrFit[i]));
    end;
  end;
// to prevent flickering
  pFit.Canvas.Draw(0,0,BitmapF);
end;

procedure TFormGA.Plot(D: TFloat);
var
  i: integer;
begin
  if ArrFitPos < High(ArrFit) then
  begin
    Inc(ArrFitPos);
  end else
  begin
    ArrFitPos := High(ArrFit);
    for i := Low(ArrFit) to ArrFitPos-1 do
      ArrFit[i] := ArrFit[i+1];
  end;
  ArrFit[ArrFitPos] := D;
  DrawFit;
end;

procedure TFormGA.ButtonStepClick(Sender: TObject);
begin
  Population.Generation;
  Display.DrawMapWithRoute(Population[0] as ITSPIndividual);
  Generations := Generations + 1;
  Plot(Population.FitnessOf(0));
end;

procedure TFormGA.ButtonRunClick(Sender: TObject);
var
  i : Integer;
begin
  for i := 1 to EditGens.Value do
  begin
    Population.Generation;
    Display.DrawMapWithRoute(Population[0] as ITSPIndividual);
    Generations := Generations + 1;
    Plot(Population.FitnessOf(0));
    Application.ProcessMessages;
  end;
end;

procedure TFormGA.PopulationChange(Sender: TObject);
var
  i : Integer;
begin
  ListBox1.Clear;

  for i := 0 to Population.Count - 1 do
  begin
    ListBox1.Items.Add(IntToStr(i+1)+': '+FloatToStr(Population.FitnessOf(i)))
  end;
end;

procedure TFormGA.EditKillChange(Sender: TObject);
begin
  KillerPercentage.Percentage := EditKill.Value;
end;

procedure TFormGA.ListBox1Click(Sender: TObject);
begin
  Display.DrawMapWithRoute(Population[ListBox1.ItemIndex] as ITSPIndividual);
end;

procedure TFormGA.EditTranspositionChange(Sender: TObject);
begin
  Mutator.Transposition := EditTransposition.Value;
end;

procedure TFormGA.EditInversionChange(Sender: TObject);
begin
  Mutator.Inversion := EditInversion.Value;
end;

procedure TFormGA.FormResize(Sender: TObject);
begin
  Display.SetRanges(0.0,11.0,0.0,11.0,1.0);
end;

end.


uDisplaytsp
{ interface-based implementation of
  Dan Taylor's ([e-mail])
  Evolutionary TSP Algorithm demo program
Modified: September 2002
  by Nikolai Shokhirev ([e-mail])
}
  { Display object }
unit uDisplayTSP;

interface

uses
  uUtilsEA, uITSP, classes, controls;

type

  TTSPDisplay = class(TPainter0)
  private
    fController: ITSPController;
    {  Clear the map }
//    procedure Clear;  //is in the base class
    {  Show the cities }
    procedure DrawCities;
    {  Display a route  }
    procedure DrawRoute(Individual : ITSPIndividual);
    function GetController: ITSPController;
    procedure SetController(const Value: ITSPController);
  public
    {  The constructor }
    constructor Create(aOwner: TComponent; aParent: TWinControl);
    {  The destructor }
    destructor Destroy; override;
    {  Call this to draw the map }
    procedure DrawMap;
    {  Draw the map with a route  }
    procedure DrawMapWithRoute(Individual : ITSPIndividual);
    property Controller: ITSPController read GetController write SetController;
  end;

implementation

uses
  Graphics;

{ TTSPDisplay }

constructor TTSPDisplay.Create(aOwner: TComponent; aParent: TWinControl);
begin
  inherited;
  Clear;
end;

destructor TTSPDisplay.Destroy;
begin
  inherited;
end;

procedure TTSPDisplay.DrawCities;
var
  i : Integer;
begin
    PenColor := clBlack;
    BrushColor := clRed;
    PenWidth := 1;
    with fController do
      for i := 0 to CityCount - 1 do
        Circle(Cities[i].x, Cities[i].y,0.2);
end;

procedure TTSPDisplay.DrawMap;
begin
  Clear;
  DrawCities;
end;

procedure TTSPDisplay.DrawMapWithRoute(Individual: ITSPIndividual);
begin
  Clear;
  DrawCities;
  DrawRoute(Individual);
end;

procedure TTSPDisplay.DrawRoute(Individual: ITSPIndividual);
var
  i, c : Integer;
begin
  {  Set the pen colour and stuff }
  PenColor := clBlue;
  PenWidth := 1;

  {  Start at the first city }
  with fController do
  begin
    if Individual.Steps > 1 then
    begin
      c := Individual.RouteArray[0];
      MoveTo(Cities[c].X, Cities[c].Y);
    end;

    {  Move round the other cities }
    for i := 1 to Individual.Steps - 1 do
    begin
      c := Individual.RouteArray[i];
      LineTo(Cities[c].X, Cities[c].Y);
    end;

    c := Individual.RouteArray[0];
    LineTo(Cities[c].X, Cities[c].Y);
  end;
end;

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

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

end.

uEA
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;