ga tsp.txt

tsp遗传算法源代码

function TTSPController.GetXmax: TFloat;
begin
  result := fXmax;
end;

function TTSPController.GetXmin: TFloat;
begin
  result := fXmin;
end;

function TTSPController.GetYmax: TFloat;
begin
  result := fYmax;
end;

function TTSPController.GetYmin: TFloat;
begin
  result := fYmin;
end;

procedure TTSPController.RandomCities;
var
  i : Integer;
begin
  for i := 0 to FCityCount - 1 do
  begin
    FCities[i].X := Xmin+0.5+(Xmax-Xmin-1.0)*Random;
    FCities[i].Y := Ymin+0.5+(Ymax-Ymin-1.0)*Random;
  end;
end;

procedure TTSPController.SetCityCount(const Value: Integer);
begin
  SetLength(fCities, Value);
  fCityCount := Value;

  RandomCities;
end;

procedure TTSPController.SetXmax(const Value: TFloat);
begin
  fXmax := Value;
end;

procedure TTSPController.SetXmin(const Value: TFloat);
begin
  fXmin := Value;
end;

procedure TTSPController.SetYmax(const Value: TFloat);
begin
  fYmax := Value;
end;

procedure TTSPController.SetYmin(const Value: TFloat);
begin
  fYmin := Value;
end;

end.

unit uIEA;

interface

uses
  uUtilsEA, Classes;

type

  IPopulation = interface;

  IIndividual = interface
  ['{BD6061C1-8529-11D6-8252-00C04F2859BF}']
    procedure SetFitness(const Value: TFloat);
    function GetFitness: TFloat;
    property Fitness: TFloat read GetFitness write SetFitness;
  end;

  TInterfaceCompare = function (Item1, Item2: IIndividual): Integer of object;

  ICreator = interface
  ['{BD6061C2-8529-11D6-8252-00C04F2859BF}']
    // Function is used to create individuals to form the initial population
    function CreateIndividual: IIndividual;
  end;

  IKiller = interface
  ['{BD6061C3-8529-11D6-8252-00C04F2859BF}']
    // Function to kill off some unfit population members
    // should delete them from the list and return the number killed
    function Kill(Pop: IPopulation) : Integer;
  end;

  IKillerPercentage = interface(IKiller)
  ['{BD6061C4-8529-11D6-8252-00C04F2859BF}']
    procedure SetPercentage(const Value: TFloat);
    function GetPercentage: TFloat;
    // function Kill(Pop : IPopulation) : Integer;
    // Percentage of population to be killed
    property Percentage : TFloat read GetPercentage write SetPercentage;
  end;

  IParentSelector = interface
  ['{BD6061C5-8529-11D6-8252-00C04F2859BF}']
    // This function returns a reference to a single parent, selected from Pop
    function SelectParent(Population: IPopulation): IIndividual;
  end;

  IBreeder = interface
  ['{BD6061C6-8529-11D6-8252-00C04F2859BF}']
    // This function should return a new population member based on parents
    // selected using the ParentSelector object
    function BreedOffspring(PSelector: IParentSelector; Pop: IPopulation): IIndividual;
  end;

  IMutator = interface
  ['{BD6061C7-8529-11D6-8252-00C04F2859BF}']
    // This function performs mutation(s) on the individual passed
    procedure Mutate(Individual : IIndividual);
  end;

  IExaminer = interface
  ['{BD6061C8-8529-11D6-8252-00C04F2859BF}']
    // Returns the fitness of an individual, where lower <=> better
    function GetFitness(Individual : IIndividual) : TFloat;
  end;

  IPopulation = interface
  ['{BD6061C9-8529-11D6-8252-00C04F2859BF}']
    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);
    // 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;

implementation

end.

unit uITSP;

interface
uses
  uUtilsEA, uIEA, Windows, Classes, controls;

type

  ITSPController = interface;

  ITSPIndividual = interface(IIndividual)
  ['{BD6061CA-8529-11D6-8252-00C04F2859BF}']
    function GetRouteArray(I: Integer): Integer;
    procedure SetRouteArray(I: Integer; const Value: Integer);
    procedure SetSteps(const Value: Integer);
    function GetSteps: Integer;
    property RouteArray[I : Integer] : Integer read GetRouteArray write SetRouteArray;
    property Steps : Integer read GetSteps write SetSteps;
//    property Fitness : TFloat read GetFitness write SetFitness;
  end;

  ITSPController = interface
  ['{BD6061CB-8529-11D6-8252-00C04F2859BF}']
    function GetXmax: TFloat;
    function GetXmin: TFloat;
    function GetYmax: TFloat;
    function GetYmin: TFloat;
    procedure SetXmax(const Value: TFloat);
    procedure SetXmin(const Value: TFloat);
    procedure SetYmax(const Value: TFloat);
    procedure SetYmin(const Value: TFloat);
    function GetCity(I: Integer): TPoint2D;
    procedure SetCityCount(const Value: Integer);
    function GetCityCount: Integer;
    {  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;
    {  Access to the cities array }
    property Cities[I: Integer] : TPoint2D read GetCity;
    {  Properties... }
    property CityCount: Integer read GetCityCount write SetCityCount;
  end;

  ITSPDisplay = interface
  ['{BD6061CC-8529-11D6-8252-00C04F2859BF}']
    {  Call this to draw the map }
    procedure DrawMap;
    {  Draw the map with a route  }
    procedure DrawMapWithRoute(Individual : ITSPIndividual);
  end;

  ITSPCreator = interface(ICreator)
  ['{BD6061CD-8529-11D6-8252-00C04F2859BF}']
    function GetController: ITSPController;
    procedure SetController(const Value: ITSPController);
    function CreateIndividual : IIndividual;
    property Controller : ITSPController read GetController write SetController;
  end;

  ITSPMutator = interface(IMutator)
  ['{BD6061CE-8529-11D6-8252-00C04F2859BF}']
    procedure SetInv(const Value: TFloat);
    procedure SetTrans(const Value: TFloat);
    function GetInv: TFloat;
    function GetTrans: TFloat;
    // 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;

  ITSPExaminer = interface(IExaminer)
  ['{BD6061CF-8529-11D6-8252-00C04F2859BF}']
    function GetController: ITSPController;
    procedure SetController(const Value: ITSPController);
    // Returns the fitness of an individual as a real number where 0 => best
    property Controller : ITSPController read GetController write SetController;
  end;

implementation

end.


unit uUtilsEA;

interface

uses
  classes, extctrls, controls, Graphics, Windows;

type

  TFloat = Double;

  TInt = Integer;

  ArrayInt = array of TInt;

  ArrayFloat = array of TFloat;

  TPoint2D = record
    X: TFloat;
    Y: TFloat;
  end;
  
// painting object, the base class for Display
  TPainter0 = class(TPaintBox)
  private
    fXmin: TFloat;
    fXmax: TFloat;
    fYmin: TFloat;
    fYmax: TFloat;
    fNXmin: TInt;
    fNXmax: TInt;
    fNYmin: TInt;
    fNYmax: TInt;
    fIWidth: TFloat;
    fIHeight: TFloat;
    fRWidth: TFloat;
    fRHeight: TFloat;
    fXYRatio: TFloat;
    fPPUX, fPPUY: TFloat;
    fBgColor: TColor; // used in Clear
    function GetXmin: TFloat;
    function GetXmax: TFloat;
    function GetYmin: TFloat;
    function GetYmax: TFloat;
    procedure SetXmin(const Value: TFloat);
    procedure SetXmax(const Value: TFloat);
    procedure SetYmin(const Value: TFloat);
    procedure SetYmax(const Value: TFloat);
    function GetXYRatio: TFloat;
    procedure SetXYRatio(const Value: TFloat);
    function GetPPUX: TFloat;
    function GetPPUY: TFloat;
    function GetBgColor: TColor;
    procedure SetBgColor(const Value: TColor);
    function GetBrushColor: TColor;
    function GetPenColor: TColor;
    procedure SetBrushColor(const Value: TColor);
    procedure SetPenColor(const Value: TColor);
    function GetPenWidth: TInt;
    procedure SetPenWidth(const Value: TInt);
  public
    constructor Create(aOwner: TComponent; aParent: TWinControl);
    destructor Destroy; override;
    procedure SetRanges(aXmin, aXmax, aYmin, aYmax, aXYRatio: TFloat);
    procedure SetPPU;
    procedure Clear;
    function rRect2iRect(x1, x2, y1, y2: TFloat): TRect;
    function rx2ix(x: TFloat): TInt;
    function ry2iy(y: TFloat): TInt;
    function ix2rx(ix: TInt): TFloat;
    function iy2ry(iy: TInt): TFloat;
    procedure MoveTo(x, y: TFloat);
    procedure LineTo(x, y: TFloat);
    procedure Line(x1, y1, x2, y2: TFloat);
    procedure Circle(x, y, r: TFloat);
    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;
    property PPUX: TFloat read GetPPUX;
    property PPUY: TFloat read GetPPUY;
    property XYRatio: TFloat read GetXYRatio write SetXYRatio;
    property BgColor: TColor read GetBgColor write SetBgColor;
    property PenColor: TColor read GetPenColor write SetPenColor;
    property PenWidth: TInt read GetPenWidth write SetPenWidth;
    property BrushColor: TColor read GetBrushColor write SetBrushColor;
  end;
  
implementation

uses
  Math;

{ Painter0 }

constructor TPainter0.Create(aOwner: TComponent; aParent: TWinControl);
begin
  inherited Create(aOwner);
  Parent := aParent;
  Align := alClient;
end;

procedure TPainter0.SetRanges(aXmin, aXmax, aYmin, aYmax, aXYRatio: TFloat);
begin
  fXmin := aXmin;
  fXmax := aXmax;
  fYmin := aYmin;
  fYmax := aYmax;
  fXYRatio := aXYRatio;
  SetPPU;
end;

destructor TPainter0.Destroy;
begin
  inherited;
  //
end;

procedure TPainter0.SetPPU;
begin
  fIWidth := ClientWidth;
  fIHeight := ClientHeight;
  fRWidth := fXmax-fXmin;
  fRHeight := fYmax-fYmin;
  fNXmin := 0;
  fNXmax := ClientWidth-1;
  fNYmin := 0;
  fNYmax := ClientHeight-1;
  if fXYRatio > 0 then
    if(1.0 > fRWidth*fIHeight*fXYRatio/fRHeight/fIWidth) then
    begin
      fPPUY := fIHeight/fRHeight;
      fPPUX := fPPUY*fXYRatio;
      fNXmin := (ClientWidth-round(fPPUX*fRWidth)) div 2;
      fNXmax := ClientWidth - fNXmin - 1;
    end else
    begin
      fPPUX := fIWidth/fRWidth;
      fPPUY := fPPUX/fXYRatio;
      fNYmin := (ClientHeight-round(fPPUY*fRHeight)) div 2;
      fNYmax := ClientHeight - fNYmin - 1;
    end
  else
  begin
    fPPUX := fIWidth/fRWidth;
    fPPUY := fIHeight/fRHeight;
  end;
end;

function TPainter0.GetXYRatio: TFloat;
begin
  result := fXYRatio;
end;

procedure TPainter0.SetXYRatio(const Value: TFloat);
begin
  fXYRatio := Value;
  SetPPU;
end;

function TPainter0.GetPPUX: TFloat;
begin
  result := fPPUX;
end;

function TPainter0.GetPPUY: TFloat;
begin
  result := fPPUY;
end;

function TPainter0.rRect2iRect(x1, x2, y1, y2: TFloat): TRect;
begin
  result := Rect(rx2ix(x1), ry2iy(y2), rx2ix(x2), ry2iy(y1));
end;

function TPainter0.rx2ix(x: TFloat): TInt;
begin
  result := fNXmin + round(PPUX*(x-fXmin));
end;

function TPainter0.ry2iy(y: TFloat): TInt;
begin
  result := fNYmax - round(PPUY*(y-fYmin));
end;

function TPainter0.ix2rx(ix: TInt): TFloat;
begin
  result := fXmin + (ix-fNXmin)/fPPUX;
end;

function TPainter0.iy2ry(iy: TInt): TFloat;
begin
  result := fYmin + (fNYmax-iy)/fPPUY;
end;

function TPainter0.GetXmin: TFloat;
begin
  result := fXmin;
end;

function TPainter0.GetXmax: TFloat;
begin
  result := fXmax;
end;

function TPainter0.GetYmin: TFloat;
begin
  result := fYmin;
end;

function TPainter0.GetYmax: TFloat;
begin
  result := fYmax;
end;

procedure TPainter0.SetXmin(const Value: TFloat);
begin
  fXmin := Value;
  SetPPU;
end;

procedure TPainter0.SetXmax(const Value: TFloat);
begin
  fXmax := Value;
  SetPPU;
end;

procedure TPainter0.SetYmin(const Value: TFloat);
begin
  fYmin := Value;
  SetPPU;
end;

procedure TPainter0.SetYmax(const Value: TFloat);
begin
  fYmax := Value;
  SetPPU;
end;

procedure TPainter0.LineTo(x, y: TFloat);
begin
  with Canvas do
    LineTo(rx2ix(x),ry2iy(y));
end;

procedure TPainter0.MoveTo(x, y: TFloat);
begin
  with Canvas do
    MoveTo(rx2ix(x),ry2iy(y));
end;

procedure TPainter0.Line(x1, y1, x2, y2: TFloat);
begin
  with Canvas do
  begin
    MoveTo(rx2ix(x1),ry2iy(y1));
    LineTo(rx2ix(x2),ry2iy(y2));
  end;
end;

procedure TPainter0.Circle(x, y, r: TFloat);
var
  ix, iy, irx, iry: TInt;
begin
  ix := rx2ix(x);
  iy := ry2iy(y);
  irx := round(r*PPUX);
  iry := round(r*PPUY);
  with Canvas do
  begin
    Ellipse(ix-irx,iy-iry,ix+irx,iy+iry);
  end;
end;

procedure TPainter0.Clear;
begin
  with Canvas do
  begin
    Brush.Color := fBgColor;
    FillRect(Parent.ClientRect);
  end;
end;

function TPainter0.GetBgColor: TColor;
begin
  result := fBgColor;
end;

procedure TPainter0.SetBgColor(const Value: TColor);
begin
  fBgColor := Value
end;

function TPainter0.GetBrushColor: TColor;
begin
  result := Canvas.Brush.Color;
end;

function TPainter0.GetPenColor: TColor;
begin
  result := Canvas.Pen.Color;
end;

procedure TPainter0.SetBrushColor(const Value: TColor);
begin
  Canvas.Brush.Color := Value;
end;

procedure TPainter0.SetPenColor(const Value: TColor);
begin
  Canvas.Pen.Color := Value;
end;

function TPainter0.GetPenWidth: TInt;
begin
  result := Canvas.Pen.Width;
end;

procedure TPainter0.SetPenWidth(const Value: TInt);
begin
  Canvas.Pen.Width := Value;
end;

end.