program LGADOS ;

{-----------------------------------------------------------------------}
{LGADOS - A DOS based version of the LGA Genetic Algorithm}

{For Distribution with the book "An Introduction to Genetic Algorithms for
Scientists and Engineers", World Scientific 1998}

{David A. Coley
Complex Systems Group
Physics Building
University of Exeter
Exeter
EX4 4QL
UK}

{Please email comments and corrections to D.A.Coley@exeter.ac.uk  }

{Before using this software please check for updates and corrections at
http://www.ex.ac.uk/cee/ga  }

{Version = 17th July 1998}

{PASCAL version written in Turbo Pascal 5. The random number library
functions RANDOM and RANDOMIZE may be non-standard to your version of PASCAL.
If so their calls should be replaced with equivalents. File output may also
require changing.}

{To try and ensure the two versions read as closely as possible,
this code has been converted from the BASIC version with the minimum
number of alterations. If PASCAL had been the starting point the
form of the code would be somewhat different and the scope of the variables
more sensible.}

{-----------------------------------------------------------------------}


{------- SET ALL THE IMPORTANT FIXED PARAMETERS. -------}

{These should be set by the user}
const
  PopulationSize = 20 ; {Must be even}
  NumberOfUnknowns = 2 ;
  SubstringLength = 12 ; {All sub-strings have the same length}
  TotalStringLength = 24 ; {NumberOfUnknowns * SubstringLength}
  MaxGeneration = 20 ; {G}
  CrossOverProbability = 0.6 ;  {Pc. >=0 and <=1}
  MutationProbability = 0.02 ;  {Pm, >=0 and <1}
  Elitism = true ; {true or false}
  ScalingConstant = 1.2 ; {A value of 0 implies no scaling}


{---------------------- DECLARE ALL GLOBAL VARIABLES ----------------}
var
  {The arrays that hold the individuals within the current population}
  Unknowns : array[1 .. PopulationSize, 1 .. NumberOfUnknowns] of real;
  Integers : array[1 .. PopulationSize, 1 .. NumberOfUnknowns] of integer;
  Strings : array[1 .. PopulationSize, 1 .. TotalStringLength] of integer;
  Fitness : array[1 .. PopulationSize] of real;

  {The new population}
  NewStrings : array[1 .. PopulationSize, 1 .. TotalStringLength] of integer;

  {The array that defines the range of the unknowns}
  Range : array[1 .. 2, 1 .. NumberOfUnknowns] of real;

  {The best individual in the past generation. Used if elitism is on}
  EliteString : array[1 .. TotalStringLength] of integer;
  EliteIntegers : array[1 .. NumberOfUnknowns] of integer;
  EliteFitness: real;
  EliteUnknowns : array[1 .. NumberOfUnknowns] of real;

{--- DECLARE VARIABLES THAT WERE NON-GLOBAL IN THE BASIC VERSION OF THE CODE---}

 Generation, FittestIndividual, NewIndividual, Mate1, Mate2 : integer ;
 MeanFitness, SumFitness : real ;

 {Output files, termed LGADOS.RES and LGADOS.ALL in the book.
 See Chapter 2 for a description of their contents}
 fRes, fAll : text;

{----------------------- LIST ALL PROCEDURES ---------------------------------}

procedure CrossOver ;
{Perform single point crossover}

var
  CrossSite, bit : integer ;

begin

CrossSite := trunc((TotalStringLength - 1) * random + 1) ; {Pick the cross-site at random}

for bit :=1 to CrossSite do {Swap bits to the left of the cross-site}
  begin
    NewStrings[NewIndividual, bit] := Strings[Mate1, bit] ;
    NewStrings[NewIndividual + 1, bit] := Strings[Mate2, bit]
  end ;

for bit :=CrossSite + 1 to TotalStringLength do {Swap bits to the right of the cross-site}
  begin
    NewStrings[NewIndividual, bit] := Strings[Mate2, bit] ;
    NewStrings[NewIndividual + 1, bit] := Strings[Mate1, bit]
  end ;

end;

procedure DefineRange ;
{Defines the upper and lower bounds of each unknown}
{Add other ranges using the same format if more than two unknowns in the problem}

var
  Unknown : integer ;

begin

  Unknown := 1 ; {the first unknown}
  Range[1, Unknown] := 0 ; {The lower bound}
  Range[2, Unknown] := 1 ; {The upper bound}

  Unknown := 2 ; {the second unknown}
  Range[1, Unknown] := 0 ;
  Range[2, Unknown] := 3.14159 ;

  {Add other ranges if more than two unknowns in your problem.}

end;

procedure FindFitness ;
{The problem at hand is used to assign a positive [or zero] fitness to
each individual in turn.}

var
  Individual : integer ;

begin
  {The problem is f :=x^2 + sin(y).}
  for Individual :=1 to PopulationSize do
    begin
      Fitness[Individual] :=sqr(Unknowns[Individual, 1])
      + SIN(Unknowns[Individual, 2]) ;
      if Fitness[Individual] < 0 then Fitness[Individual] :=0
    end ;

end;

procedure FindIntegers ;
{Decode the strings to sets of decimal integers.}

var
  bit, Individual, StringBit, Unknown : integer ;

begin

  for Individual :=1 to PopulationSize do
    begin
      bit :=TotalStringLength + 1 ;
      for Unknown := NumberOfUnknowns downto 1 do
        begin
          Integers[Individual, Unknown] := 0 ;
          for StringBit :=1 to SubstringLength do
            begin
              bit :=bit - 1 ;
              if Strings[Individual, bit] =1 then
                Integers[Individual, Unknown] :=Integers[Individual, Unknown]
                + round(exp((StringBit - 1) * ln(2)))
            end ; {for StringBit}
      end ; {for Unknown}
    end ; {for Individual}

end;

procedure FindUnknowns ;
{Decode the strings to real numbers.}

var
  Individual, Unknown : integer ;

begin

  FindIntegers ; {First decode the strings to sets of decimal integers.}

  {Now convert these integers to reals.}
  for Individual :=1 to PopulationSize do
    begin
      for Unknown :=1 to NumberOfUnknowns do
        Unknowns[Individual, Unknown] :=Range[1, Unknown] +
        Integers[Individual, Unknown] * (Range[2, Unknown] -
        Range[1, Unknown]) / (exp(SubstringLength * ln(2)) - 1)

  end ; {for Individual}

end;

procedure InitialPopulation ;
{Create the initial random population.}

var
Individual, bit : integer ;

begin

  for Individual :=1 to PopulationSize do
    begin
    for bit :=1 to TotalStringLength do
      begin
	Strings[Individual, bit] :=0;
        if random > 0.5 then Strings[Individual, bit] :=1

      end ; {for bit}

    end ; {for Individual}

  FindUnknowns ; {Decode strings to real numbers.}

end;

procedure Mutate ;
{Visit each bit of each string very occasionally flipping a "1" to a "0" or
vice versa.}

var
  Individual, bit : integer ;

begin

  for Individual :=1 to PopulationSize do
    begin
      for bit :=1 to TotalStringLength  do
        begin
          {Throw a random number and see if it is less than or equal to the
          mutation probability.}
          if random <= MutationProbability then
            if NewStrings[Individual, bit] =1 then
                    NewStrings[Individual, bit] :=0
            else
                    NewStrings[Individual, bit] :=1
        end ; {for bit}
    end ; {for Individual}

end;

procedure NoCrossover ;
{Pass the selected strings to the temporary population without applying
crossover.}

var
  bit : integer ;

begin

  for bit :=1 to TotalStringLength do
    begin
      NewStrings[NewIndividual, bit] :=Strings[Mate1, bit] ;
      NewStrings[NewIndividual + 1, bit] :=Strings[Mate2, bit]
    end ; {for bit}

end;

procedure PrintGeneration ;
{Print results to the screen and the files}

var
  Unknown, Individual, Bit : integer ;

begin

  write(Generation, Fitness[FittestIndividual], MeanFitness) ; {Screen}

  write(fRes, Generation, ',', Fitness[FittestIndividual], ',', MeanFitness) ; {File LGARES}

  for Unknown :=1 to NumberOfUnknowns do
    begin
      write(Unknowns[FittestIndividual, Unknown]) ; {Screen}
      write(fRes, ',', Unknowns[FittestIndividual, Unknown]) ; {File LGARES}
    end ; {for Unknown}

  writeln ; {Carriage return}
  writeln(fRes) ; {Carriage return}

  for Individual :=1 to PopulationSize  do
    begin
      write(fAll, Generation, ',', Fitness[Individual], ',') ; {File LGAALL}

      for Unknown :=1 to NumberOfUnknowns do
        begin
        write(fAll, Unknowns[Individual, Unknown], ',') ; {File LGAALL}
        write(fAll, Integers[Individual, Unknown], ',')
        end;
      for bit :=1 to TotalStringLength do
        write(fAll, Strings[Individual, bit], ',') ; {File LGAALL}

      writeln(fAll) {Carriage return}

    end ; {for Individual}

end;

procedure Replace ;
{Replace the old population with the new one}

var
  Individual, bit : integer ;

begin

  for Individual :=1 to PopulationSize do
    for bit :=1 to TotalStringLength do
      Strings[Individual, bit] :=NewStrings[Individual, bit] ;

end;

procedure Scaling ;

{Apply Linear Fitness Scaling,
      scaledfitness :=a * fitness + b
Subject to,
      meanscaledfitness :=meanfitness
and
      bestscaledfitness :=c * meanfitness,
where c, the scaling constant, is set by the user}

var
   a, b : real ;
   Individual : integer ;

begin

  {If the scaling constant is set to zero, or all individuals have the same
  fitness, scaling is not applied}
  if (ScalingConstant <> 0.0) AND (Fitness[FittestIndividual] - MeanFitness > 0.0) then
    begin {Find a and b}
{    writeln('error')}
      a :=(ScalingConstant - 1) * MeanFitness /
      (Fitness[FittestIndividual] - MeanFitness) ;

      b :=(1 - a) * MeanFitness ;

      {Adjust the fitness of all members of the population}
      SumFitness :=0 ;
      for Individual :=1 to PopulationSize do
        begin
          Fitness[Individual] :=a * Fitness[Individual] + b ;
          if Fitness[Individual] < 0 then Fitness[Individual] :=0 ; {Avoid negative values near the end of a run}
          SumFitness :=SumFitness + Fitness[Individual] {Adjust the sum of all the fitnesses}
        end ; {for Individual}

      {Adjust the mean of all the fitnesses}
      MeanFitness :=SumFitness / PopulationSize

  end ;

end;

procedure Selection (var mate : integer) ;
{Select a single individual by fitness proportional selection}

var
  Sum, RouletteWheel : real ;
  Individual : integer ;

begin

  Sum :=0 ;
  Individual :=0 ;

 RouletteWheel := random * SumFitness ;

  repeat
    Individual :=Individual + 1 ;
    Sum :=Sum + Fitness[Individual]
  until (Sum >= RouletteWheel) OR (Individual = PopulationSize) ;

  mate :=Individual

end;

procedure Statistics ;
{Calculate the sum of fitness across the population and find the best individual,
{then apply elitism if required}

var
  Individual : integer ;
  MaxFitness : real ;

procedure Elite ;
{Applies elitism by replacing a randomly chosen individual by the elite member
from the previous population if the new max fitness is less then the previous value.}

var
    Individual, bit, Unknown : integer ;

begin

  if Fitness[FittestIndividual] < EliteFitness then
    begin
      Individual := trunc(PopulationSize * random + 1) ; {Chosen individual to be replaced.}

      for bit :=1 to TotalStringLength do
        Strings[Individual, bit] := EliteString[bit] ;

      Fitness[Individual] := EliteFitness ;

      for Unknown :=1 to NumberOfUnknowns do
        begin
         Integers[Individual, Unknown] := EliteIntegers[Unknown] ;
         Unknowns[Individual, Unknown] := EliteUnknowns[Unknown]
        end ;  {Unknown}

      FittestIndividual := Individual

    end ; {if Fitness....}

  for bit :=1 to TotalStringLength do
    EliteString[bit] := Strings[FittestIndividual, bit] ;

  EliteFitness := Fitness[FittestIndividual] ;

  for Unknown :=1 to NumberOfUnknowns do
    begin
      EliteIntegers[Unknown] :=Integers[FittestIndividual, Unknown] ;
      EliteUnknowns[Unknown] :=Unknowns[FittestIndividual, Unknown]
    end ; {for Unknown}

end;

begin
  FittestIndividual := 0 ;
  MaxFitness := 0 ;

  for Individual :=1 to PopulationSize do
    if Fitness[Individual] > MaxFitness then
      begin
        MaxFitness :=Fitness[Individual] ;
        FittestIndividual :=Individual
      end ; {if}

  IF Elitism = true then {Apply elitism}
    Elite;

  SumFitness :=0 ; {Sum the fitness}
  for Individual :=1 to PopulationSize do
    SumFitness :=SumFitness + Fitness[Individual] ;

  {Find the average fitness of the population}
  MeanFitness :=SumFitness / PopulationSize;

end;

{----------------------- END OF PROCEDURES ---------------------------------}

begin {LGADOS}

  {Setup output files}
  assign(fRes, 'LGADOS.RES');
  assign(fAll, 'LGADOS.ALL');
  rewrite(fRes);
  rewrite(fAll);

  DefineRange ;  {Define the range of each unknown. These should also be set by the user}

  {Set the random number generator so it produces a different set of numbers
  {each time LGADOS is run}
  randomize;

  {------- START OF THE GENETIC ALGORITHM -------}

  {------- CREATE AN INITIAL POPULATION, GENERATION 1 ------}

  Generation := 1 ;

  InitialPopulation ; {Build a population of strings at random}

  FindFitness ; {Find the fitness of each member of the population}

  Statistics ; {Find the mean fitness and the fittest individual}

  PrintGeneration ; {Print generation to file}

  {If linear fitness scaling is "on" then scale population prior to selection}
  Scaling ;

  {------- LOOP OVER ALL THE GENERATIONS -------}

  for Generation :=2 to MaxGeneration do
   begin

   NewIndividual :=1 ;
   repeat {Loop over the population choosing pairs of mates}

       Selection(Mate1);  {Choose first mate}
       Selection(Mate2);  {Choose second mate}

       {Pass individuals to the temporary population either with or without performing crossover}
       if random <= CrossOverProbability then  {Perform crossover}
         CrossOver
       else {Don't perform crossover}
         NoCrossover ;

       NewIndividual := NewIndividual + 2

   until NewIndividual > PopulationSize ;

    Mutate ; {Mutate the temporary population}

    Replace ; {Replace the old population completely by the new one}

    FindUnknowns ; {De-code the new population to integers then real numbers}

    FindFitness ; {Find the fitness of each member of the population}

    Statistics ; {Find the mean fitness and the fittest individual}

    PrintGeneration ; {Print generation to file}

    Scaling ; {If linear fitness scaling is "on"
    then scale population prior to selection}

  end ; {for Generation}

    {Close output files}
    close(fAll);
    close(fRes)

end. {of LGADOS}