AutoBuildRelayAlgorithm.pas

unit AutoBuildRelayAlgorithm;

interface

uses
System.Classes;

// Bin packing algorithm in Delphi using a genetic algorithm

// Define the container and item types
type
  TLane = record
    Capacity: Integer;
    Swimmers: array of Integer;
  end;

  TSwimmer = record
    RaceTime: Integer;
    NormalizedRaceTime: Double;
  end;

  TChromosome = record
    Genes: array of Integer;
    Fitness: Double;
  end;

const
  POPULATION_SIZE = 100;
  MUTATION_RATE = 0.05;
  CROSSOVER_RATE = 0.8;
  MAX_GENERATIONS = 1000;

//  var
//  Population: array[0..POPULATION_SIZE - 1] of TChromosome;


implementation

uses System.Math, system.Generics.Collections;

// Define the comparison function for sorting the chromosomes by their fitness
function CompareChromosomes(Item1, Item2: Pointer): Integer;
begin
  if TChromosome(Item1^).Fitness > TChromosome(Item2^).Fitness then
    Result := -1
  else if TChromosome(Item1^).Fitness < TChromosome(Item2^).Fitness then
    Result := 1
  else
    Result := 0;
end;

// Define the quicksort function
procedure QuickSort(var A: array of TChromosome; iLo, iHi: Integer; Compare: TListSortCompare);
var
  Lo, Hi: Integer;
  Pivot, T: TChromosome;
begin
  Lo := iLo;
  Hi := iHi;
  Pivot := A[(Lo + Hi) div 2];
  repeat
    while Compare(@A[Lo], @Pivot) < 0 do Inc(Lo);
    while Compare(@A[Hi], @Pivot) > 0 do Dec(Hi);
    if Lo <= Hi then
    begin
      T := A[Lo];
      A[Lo] := A[Hi];
      A[Hi] := T;
      Inc(Lo);
      Dec(Hi);
    end;
  until Lo > Hi;
  if Hi > iLo then QuickSort(A, iLo, Hi, Compare);
  if Lo < iHi then QuickSort(A, Lo, iHi, Compare);
end;

// Define the mean function
function Mean(Data: array of Integer): Double;
var
  i, Sum: Integer;
begin
  Sum := 0;
  for i := 0 to High(Data) do Inc(Sum, Data[i]);
  Result := Sum / Length(Data);
end;

// Define the standard deviation function
function StandardDeviation(Data: array of Integer): Double;
var
  i: Integer;
  MeanValue, SumOfSquares: Double;
begin
  MeanValue := Mean(Data);
  SumOfSquares := 0;
  for i := 0 to High(Data) do SumOfSquares := SumOfSquares + Sqr(Data[i] - MeanValue);
  Result := Sqrt(SumOfSquares / Length(Data));
end;

// Define the fitness function
function CalculateFitness(Chromosome: TChromosome; Lanes: array of TLane; Swimmers: array of TSwimmer): Double;
var
  i, j: Integer;
  LaneRaceTimes: array of Integer;
begin
  // Initialize the lane race times to zero
  SetLength(LaneRaceTimes, Length(Lanes));
  for i := 0 to High(LaneRaceTimes) do LaneRaceTimes[i] := 0;

  // Calculate the total race time for each lane
  for i := 0 to High(Chromosome.Genes) do begin
    j := Chromosome.Genes[i];
    Inc(LaneRaceTimes[j], Swimmers[i].RaceTime);
  end;

  // Calculate the fitness as the inverse of the standard deviation of the lane race times
  //  Result := Mean(LaneRaceTimes);
  Result := StandardDeviation(LaneRaceTimes);
  if Result <> 0 then Result := 1 / Result else Result := MaxInt;
end;

// Define the selection function
function SelectParent(Population: array of TChromosome): Integer;
var
  i: Integer;
  TotalFitness, CumulativeFitness, RandomValue: Double;
begin
  // Calculate the total fitness of the population
  TotalFitness := 0;
  for i := 0 to High(Population) do
  TotalFitness := TotalFitness + Population[i].Fitness;

  // Select a parent using roulette wheel selection
  RandomValue := Random * TotalFitness;
  CumulativeFitness := 0;
  for i := 0 to High(Population) do begin
    CumulativeFitness := CumulativeFitness + Population[i].Fitness;
    if CumulativeFitness >= RandomValue then begin
      Result := i;
      Exit;
    end;
  end;

  // If no parent was selected, return the last chromosome in the population
  Result := High(Population);
end;

// Define the crossover function
procedure Crossover(var Chromosome1, Chromosome2: TChromosome);
var
  i, j, k, CrossoverPoint: Integer;
begin
  // Perform single-point crossover
  if Random < CROSSOVER_RATE then begin
    CrossoverPoint := RandomRange(0, Length(Chromosome1.Genes));
    for i := CrossoverPoint to High(Chromosome1.Genes) do begin
      j := Chromosome1.Genes[i];
      k := Chromosome2.Genes[i];
      Chromosome1.Genes[i] := k;
      Chromosome2.Genes[i] := j;
    end;
  end;
end;

// Define the mutation function
procedure Mutate(var Chromosome: TChromosome);
var
  i, j, k: Integer;
begin
  // Perform swap mutation on each gene with a small probability
  for i := 0 to High(Chromosome.Genes) do begin
    if Random < MUTATION_RATE then begin
      j := Chromosome.Genes[i];
      k := RandomRange(0, Length(Chromosome.Genes));
      Chromosome.Genes[i] := Chromosome.Genes[k];
      Chromosome.Genes[k] := j;
    end;
  end;
end;

// Define the bin packing function using a genetic algorithm
function BinPack(Lanes: array of TLane; Swimmers: array of TSwimmer): TArray<Integer>;
var
  i, j, k, Generation: Integer;
  Population: array[0..POPULATION_SIZE - 1] of TChromosome;
  Parent1, Parent2, Offspring1, Offspring2: TChromosome;
  BestChromosome: TChromosome;
begin
  // Initialize the population with random chromosomes
  for i := 0 to High(Population) do begin
    SetLength(Population[i].Genes, Length(Swimmers));
    for j := 0 to High(Population[i].Genes) do Population[i].Genes[j] := Random(Length(Lanes));
    Population[i].Fitness := CalculateFitness(Population[i], Lanes, Swimmers);
  end;

  // Initialize the best chromosome
  BestChromosome.Fitness := 0;

  // Run the genetic algorithm for a fixed number of generations
  for Generation := 1 to MAX_GENERATIONS do begin
    // Sort the population by fitness
    QuickSort(Population, Length(Population), SizeOf(TChromosome), CompareChromosomes);

    // Update the best chromosome
    if Population[0].Fitness > BestChromosome.Fitness then BestChromosome := Population[0];

    // Create a new population using selection, crossover, and mutation
    for i := 0 to High(Population) div 2 do begin
      // Select two parents
      j := SelectParent(Population);
      k := SelectParent(Population);
      Parent1 := Population[j];
      Parent2 := Population[k];

      // Create two offspring using crossover
      Offspring1 := Parent1;
      Offspring2 := Parent2;
      Crossover(Offspring1, Offspring2);

      // Mutate the offspring
      Mutate(Offspring1);
      Mutate(Offspring2);

      // Calculate the fitness of the offspring
      Offspring1.Fitness := CalculateFitness(Offspring1, Lanes, Swimmers);
      Offspring2.Fitness := CalculateFitness(Offspring2, Lanes, Swimmers);

      // Add the offspring to the new population
      Population[i * 2] := Offspring1;
      Population[i * 2 + 1] := Offspring2;
    end;
  end;

  // Return the best solution found by the genetic algorithm
  SetLength(Result, Length(BestChromosome.Genes));
  for i := Low(BestChromosome.Genes) to High(BestChromosome.Genes) do
    Result[i] := BestChromosome.Genes[i];
end;

(*
procedure QuickSortI(lLowBound, lHighBound: integer; lCompare: TListSortCompare;
  lSwap: TListSortSwap);
var
  lLeft: Integer;
  lRight: Integer;
  lPivot: Integer;
  lLeftCompare: Integer;
  lRightCompare: Integer;
  lStack: array of integer;
  lStackLen: integer;
begin
  if lHighBound > lLowBound then
  begin
    lStackLen := 2;
    SetLength(lStack, lStackLen);
    lStack[lStackLen - 1] := lLowBound;
    lStack[lStackLen - 2] := lHighBound;

    repeat
      lLowBound := lStack[lStackLen - 1];
      lHighBound := lStack[lStackLen - 2];
      SetLength(lStack, lStackLen - 2);
      Dec(lStackLen, 2);

      lLeft := lLowBound;
      lRight := lHighBound;
      lPivot := (lLowBound + lHighBound) div 2;
      repeat
        lLeftCompare := lCompare(lLeft, lPivot);
        while lLeftCompare < 0 do
        begin
          Inc(lLeft);
          lLeftCompare := lCompare(lLeft, lPivot);
        end;
        lRightCompare := lCompare(lRight, lPivot);
        while lRightCompare > 0 do
        begin
          Dec(lRight);
          lRightCompare := lCompare(lRight, lPivot);
        end;

        if lLeft <= lRight then
        begin
          if not ((lLeftCompare = 0) and (lRightCompare = 0)) then
          begin
            lSwap(lRight, lLeft);

            if lPivot = lLeft then
              lPivot := lRight
            else if lPivot = lRight then
              lPivot := lLeft;
          end;
          Inc(lLeft);
          Dec(lRight);
        end;
      until lLeft > lRight;

      if (lHighBound > lLeft) then
      begin
        Inc(lStackLen, 2);
        SetLength(lStack, lStackLen);
        lStack[lStackLen - 1] := lLeft;
        lStack[lStackLen - 2] := lHighBound;
      end;

      if (lLowBound < lRight) then
      begin
        Inc(lStackLen, 2);
        SetLength(lStack, lStackLen);
        lStack[lStackLen - 1] := lLowBound;
        lStack[lStackLen - 2] := lRight;
      end;

    until lStackLen = 0;
  end;
end;
*)


end.