用GA解VRP.doc

【程序的算法单元delphi写的】
unit uEA;

interface

uses
uUtilsEA, uIEA, uITSP, Classes, GaPara, windows, SysUtils, fEA_TSP;

type
TIndividual = class(TInterfacedObject, IIndividual)
private
// The internally stored fitness value
fFitness: TFloat;
fWeConstrain: integer;
fBackConstrain: integer;
fTimeConstrain: integer;
procedure SetFitness(const Value: TFloat);
function GetFitness: TFloat;
function GetWeConstrain: integer;
procedure SetWeConstrain(const Value: integer);
procedure SetBackConstrain(const Value: integer);
function GetBackConstrain: integer;
function GetTimeConstrain: integer;
procedure SetTimeConstrain(const Value: integer);
public
property Fitness : TFloat read GetFitness write SetFitness;
property WeConstrain :integer read GetWeConstrain write SetWeConstrain;
property BackConstrain :integer read GetBackConstrain write SetBackConstrain;
property TimeConstrain :integer read GetTimeConstrain write SetTimeConstrain;
end;

TTSPIndividual = class(TIndividual, ITSPIndividual)
private
// The route we travel
fRouteArray : ArrayInt;
fWeConstrain: integer;
fBackConstrain: integer;
fTimeConstrain: integer;
function GetRouteArray(I: Integer): Integer;
procedure SetRouteArray(I: Integer; const Value: Integer);
procedure SetSteps(const Value: Integer);
function GetSteps: Integer;
function GetWeConstrain: integer;
procedure SetWeConstrain(const Value: integer);
procedure SetBackConstrain(const Value: integer);
procedure SetTimeConstrain(const Value: integer);
function GetBackConstrain: integer;
function GetTimeConstrain: 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;
property WeConstrain :integer read GetWeConstrain write SetWeConstrain;
property BackConstrain :integer read GetWeConstrain write SetBackConstrain;
property TimeConstrain :integer read GetTimeConstrain write SetTimeConstrain;
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;
function CreateFeasibleIndividual: 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 array of 'vehicles' }
fVehicles : array of TVehicle;
{ The array of 'vehicle number' }
fNoVehicles : ArrayInt;/////////////////////
{ The number of 'new cities' }
fCityCount: Integer;
{ The number of 'old cities' }
foldCityCount: Integer;
{ The number of 'travelers' }
fTravelCount:Integer; ///////////////////////
{ The number of 'depots' }
fDepotCount:Integer; ///////////////////////
{ Getters... }
function GetCity(I: Integer): TPoint2D;
function GetNoVehicle(I: Integer): TInt;
function GetCityCount: Integer;
function GetOldCityCount: Integer;
function GetTravelCount:Integer;
function GetDepotCount:Integer;
function GetXmax: TFloat;
function GetXmin: TFloat;
function GetYmax: TFloat;
function GetYmin: TFloat;
{ Setters... }
procedure SetCityCount(const Value: Integer);
procedure SetOldCityCount(const Value: Integer);
procedure SetTravelCount(const Value: Integer); /////////////
procedure SetDepotCount(const Value: Integer); /////////////
procedure SetXmax(const Value: TFloat);
procedure SetXmin(const Value: TFloat);
procedure SetYmax(const Value: TFloat);
procedure SetYmin(const Value: TFloat);
function TimeCostBetween(C1, C2: Integer): TFloat;
function GetTimeConstraint(Individual: IIndividual): TInt;
function DateSpanToMin(d1, d2: TDateTime): integer;
function GetVehicleInfo(routeInt: Tint): integer;
procedure writeTimeArray;
procedure writeCostArray;
public
{ The constructor }
constructor Create;
{ The destructor }
destructor Destroy; override;
{ Get the distance between two cities }
function DistanceBetween(C1, C2 : Integer) : TFloat;
{ Get the cost between two cities }
function CostBetween(C1, C2: Integer): TFloat;

function GetWeightConstraint( Individual: IIndividual): TInt;

function GetBackConstraint( Individual: IIndividual): TInt;
{ 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;
property OldCityCount : Integer read GetOldCityCount write SetOldCityCount;
property TravelCount : Integer read GetTravelCount write SetTravelCount; ///////////
property DepotCount : Integer read GetDepotCount write SetDepotCount; ///////////
{ Access to the cities array }
property Cities[I : Integer] : TPoint2D read GetCity;
property NoVehicles[I : Integer] : TInt read GetNoVehicle; ///////////////
end;

implementation

uses
Math;

{ TIndividual }

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

function TIndividual.GetWeConstrain: integer;
begin
result := fWeConstrain;
end;

function TIndividual.GetBackConstrain: integer;
begin
result := fBackConstrain;
end;

function TIndividual.GetTimeConstrain: integer;
begin
result := fTimeConstrain;
end;

procedure TIndividual.SetBackConstrain(const Value: integer);
begin
fBackConstrain := Value;
end;

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

procedure TIndividual.SetWeConstrain(const Value: integer);
begin
fWeConstrain := Value;
end;

procedure TIndividual.SetTimeConstrain(const Value: integer);
begin
fTimeConstrain := 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;

function TTSPIndividual.GetWeConstrain: integer;
begin
result := fWeConstrain;
end;

function TTSPIndividual.GetBackConstrain: integer;
begin
result := fBackConstrain;
end;

function TTSPIndividual.GetTimeConstrain: integer;
begin
result := fTimeConstrain;
end;

procedure TTSPIndividual.SetWeConstrain(const Value: integer);
begin
fWeConstrain := Value;
end;

procedure TTSPIndividual.SetBackConstrain(const Value: integer);
begin
fBackConstrain := Value;
end;

procedure TTSPIndividual.SetTimeConstrain(const Value: integer);
begin
fTimeConstrain := Value;
end;

{ TTSPCreator }

function TTSPCreator.CreateIndividual: IIndividual;
var
New: ITSPIndividual;
i, j, Top, Temp : Integer;
//trav: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.CreateFeasibleIndividual: IIndividual;
var
New: ITSPIndividual;
i, j, Top, Temp : Tint;
Msg:TMsg;
begin
// Get the number of cities
Top := fController.CityCount;
// Create the new individual
New := TTSPIndividual.Create(Top);
// Initialise it with a sequential route
repeat
begin//////////////////////////////////
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;
//process message sequence//////////
while PeekMessage(Msg,0,0,0,1) do///
begin ///
if Msg.Message<>18 then ///
begin ///
TranslateMessage(Msg); ///
DispatchMessage(Msg); ///
end; ///
end; ///
////////////////////////////////////
end
until (fController.GetWeightConstraint(New)=0)and(fController.GetBackConstraint(New)=0);

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;