Skip to content

Commit

Permalink
* Added #21
Browse files Browse the repository at this point in the history 
* Added #16
* Fixed #11
* Fixed #7

Fixed/Reworked
 - Stack selection
 - Global refactoring (Cleraing [dcc32 Warnings/Hints]
  • Loading branch information
Oleksiy Penkov committed Jul 19, 2023
1 parent e817b9c commit fbcb3fc
Show file tree
Hide file tree
Showing 42 changed files with 2,517 additions and 416 deletions.
58 changes: 41 additions & 17 deletions LFPSO/unit_LFPSO_Base.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -77,8 +77,8 @@ TLFPSO_BASE = class
procedure InitVelocity; virtual;
procedure UpdatePSO(const t: integer); virtual;
procedure UpdateLFPSO(const t: integer); virtual;
procedure Seed;virtual;
procedure ReSeed;virtual;
procedure RangeSeed;virtual;
procedure XSeed;virtual;
procedure SetStructure(const Inp: TFitStructure); virtual;
procedure UpdateStructure(Solution:TSolution); virtual;
function FitModelToLayer(Solution: TSolution): TLayeredModel; virtual;
Expand All @@ -88,9 +88,9 @@ TLFPSO_BASE = class
function Rand(const dx: Single): single;
function GetPolynomes: TProfileFunctions; virtual;
private
procedure Shake(var SuccessCount, ReInitCount, t: integer; Vmax0: single);
procedure Shake(const t: integer; var SuccessCount, ReInitCount: integer; Vmax0, Ksxr0: single);
procedure SendUpdateStep(const Step: integer);
procedure CalcSolution(const X: TSolution);
procedure CalcSolution(const X: TSolution);

public
constructor Create;
Expand Down Expand Up @@ -203,7 +203,7 @@ function TLFPSO_BASE.Rand(const dx: Single):single;
Result := (-1 + 2 * Random) * dx;
end;

procedure TLFPSO_BASE.ReSeed;
procedure TLFPSO_BASE.XSeed;
begin

end;
Expand All @@ -218,9 +218,30 @@ constructor TLFPSO_BASE.Create;
inherited ;
end;

destructor TLFPSO_BASE.Destroy;
procedure ClearArray(var A: TPopulation); inline;
begin
Finalize(A);
end;

procedure ClearSolution(var A: TSolution); inline;
begin
// SetLength(A, 0);
Finalize(A);
end;

destructor TLFPSO_BASE.Destroy;
begin
ClearArray(X);
ClearArray(V);
ClearArray(Xmax);
ClearArray(Xmin);
ClearArray(Vmax);
ClearArray(Vmin);
ClearArray(XRange);

ClearSolution(pbest);
ClearSolution(abest);
ClearSolution(gbest);
inherited;
end;

Expand Down Expand Up @@ -277,7 +298,7 @@ procedure TLFPSO_BASE.InitVelocity;

procedure TLFPSO_BASE.ApplyCFactor(var c1, c2: single);
begin
if FFitParams.CFactor and (CFactor > 0) then
if FFitParams.AdaptVel and (CFactor > 0) then
begin
c1 := c1m * CFactor;
c2 := c2m * CFactor;
Expand Down Expand Up @@ -364,7 +385,7 @@ procedure TLFPSO_BASE.CalcSolution;

function TLFPSO_BASE.FindTheBest: boolean;
var
i, Best:integer;
i : integer;
begin
Result := False;
FLastBestChiSqr := 1e12;
Expand All @@ -391,7 +412,6 @@ function TLFPSO_BASE.FindTheBest: boolean;
// ShowMessage(Format('%f %f %f',[abest[0][1][0], abest[0][1][1], FAbsoluteBestChiSqr]));
end;
CFactor := eps + (FLastBestChiSqr - FAbsoluteBestChiSqr)/ (FLastWorseChiSQR - FGlobalBestChiSqr);
// CFactor := 1;
end
else begin
SetLength(FResultingCurve, 0);
Expand All @@ -404,10 +424,10 @@ procedure TLFPSO_BASE.Init(const Step: integer);
begin
FJammingCount := 0;

if Step = 0 then
Seed
if (Step = 0) and FFitParams.RangeSeed then
RangeSeed
else
ReSeed;
XSeed;

InitVelocity;
FindTheBest;
Expand All @@ -416,7 +436,7 @@ procedure TLFPSO_BASE.Init(const Step: integer);
SendUpdateMessage(Step);
end;

procedure TLFPSO_BASE.Shake(var SuccessCount, ReInitCount, t: integer; Vmax0: single);
procedure TLFPSO_BASE.Shake(const t: integer; var SuccessCount, ReInitCount: integer; Vmax0, Ksxr0: single);
var
TmpStructure: TFitStructure;
begin
Expand All @@ -427,11 +447,13 @@ procedure TLFPSO_BASE.Shake(var SuccessCount, ReInitCount, t: integer; Vmax0: s
gbest := Copy(abest, 0, MaxInt); // recover to absolute best solution
FGlobalBestChiSqr := FAbsoluteBestChiSqr;
FFitParams.Vmax := Vmax0;
FFitParams.Ksxr := Ksxr0;
end
else
begin
FGlobalBestChiSqr := FGlobalBestChiSqr * FFitParams.KChiSqr;
FFitParams.Vmax := FFitParams.Vmax * FFitParams.KVmax;
FFitParams.Ksxr := FFitParams.Ksxr * FFitParams.KVmax;
end;
UpdateStructure(gbest); // re-init based on current global best solution
TmpStructure := FStructure;
Expand All @@ -448,14 +470,15 @@ procedure TLFPSO_BASE.Run;
t: integer;
switch: double;
ReInitCount: integer;
Vmax0: single;
Vmax0, Ksxr0: single;
SuccessCount: integer;
begin
Randomize;

FReInit := False;
FTerminated := False;
Vmax0 := FFitParams.Vmax ;
Ksxr0 := FFitParams.Ksxr ;
ReInitCount := 0;
SuccessCount := 0;
FGlobalBestChiSqr:= 1e12;
Expand All @@ -468,6 +491,7 @@ procedure TLFPSO_BASE.Run;
for t := 1 to FTMax do
begin
if FTerminated then Break;
Randomize;

switch := Random;
if switch < 0.5 then
Expand All @@ -483,15 +507,15 @@ procedure TLFPSO_BASE.Run;
if FGlobalBestChiSqr < FFitParams.Tolerance then Break;

if FFitParams.Shake and (FJammingCount > FFitParams.JammingMax) then
Shake(SuccessCount, ReInitCount, t, Vmax0)
Shake(t, SuccessCount, ReInitCount, Vmax0, Ksxr0)
else
inc(SuccessCount);
end;
// ShowMessage(Format('%f %f %f',[abest[0][1][0], abest[0][1][1], FAbsoluteBestChiSqr]));
UpdateStructure(abest); // don't delete!
end;

procedure TLFPSO_BASE.Seed;
procedure TLFPSO_BASE.RangeSeed;
begin

end;
Expand Down Expand Up @@ -536,7 +560,7 @@ procedure TLFPSO_BASE.SendUpdateStep(const Step: integer);

procedure TLFPSO_BASE.SetDomain(const Count: integer; var X: TPopulation);
var
i, j, k, p: integer;
i: integer;
begin
SetLength(X, FPopulation);
for I := 0 to High(X) do
Expand Down
38 changes: 19 additions & 19 deletions LFPSO/unit_LFPSO_Periodic.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,10 +9,10 @@ interface
type

TLFPSO_Periodic = class (TLFPSO_BASE)
private
protected
procedure UpdateLFPSO(const t: integer); override;
procedure Seed; override;
procedure ReSeed; override;
procedure RangeSeed; override;
procedure XSeed; override;
procedure NormalizeD(const ParticleIndex: integer);
procedure SetStructure(const Inp: TFitStructure); override;
procedure UpdatePSO(const t: integer); override;
Expand Down Expand Up @@ -104,20 +104,33 @@ procedure TLFPSO_Periodic.NormalizeD; // keep D for every periodic stack constan
end;
end;

procedure TLFPSO_Periodic.ReSeed;
procedure TLFPSO_Periodic.XSeed;
var
i, j, k: integer;
begin
for i := 0 to High(X) do // for every member of the population
for i := 1 to High(X) do // for every member of the population
begin
for j := 0 to High(X[i]) do //for every layer
for k := 1 to 3 do // for H, s, rho
X[i][j][k][0] := X[0][j][k][0] + Rand(XRange[0][j][k][0]);
X[i][j][k][0] := X[0][j][k][0] + Rand(XRange[0][j][k][0] * FFitParams.Ksxr);

NormalizeD(i);
end;
end;

procedure TLFPSO_Periodic.RangeSeed;
var
i, j, k: integer;
begin
for i := 0 to High(X) do // for every member of the population
begin
for j := 0 to High(X[i]) do //for every layer
for k := 1 to 3 do // for H, s, rho
X[i][j][k][0] := Xmin[0][j][k][0] + Random * XRange[0][j][k][0]; // min + Random * (min-max)
NormalizeD(i);
end;
end;

procedure TLFPSO_Periodic.InitVelocity;
var
i, j, k: integer;
Expand All @@ -131,19 +144,6 @@ procedure TLFPSO_Periodic.InitVelocity;
V[i][j][k][0] := Random * (Vmax[0][j][k][0] - Vmin[0][j][k][0]) + Vmin[0][j][k][0];
end;

procedure TLFPSO_Periodic.Seed;
var
i, j, k: integer;
begin
for i := 0 to High(X) do // for every member of the population
begin
for j := 0 to High(X[i]) do //for every layer
for k := 1 to 3 do // for H, s, rho
X[i][j][k][0] := Xmin[0][j][k][0] + Random * XRange[0][j][k][0]; // min + Random * (min-max)
NormalizeD(i);
end;
end;

procedure TLFPSO_Periodic.SetStructure(const Inp: TFitStructure);
var
i, j, p, Index: integer;
Expand Down
Loading

0 comments on commit fbcb3fc

Please sign in to comment.