_GENETIC ALGORITHMS_
by Richard Spillman

[LISTING ONE]

{****************************************************************************}
{* GENERAL GENETIC ALGORITHM--a simple implmentation of a genetic algorithm *}
{* for function optimization. Dr. Richard Spillman, Dept.of Computer Science*}
{* Pacific Lutheran Uni. Tacoma WA 98447 206-535-7406 BITNET: SPILLMAN_R@PLU*}
{****************************************************************************}
program GGA;
uses Crt,Dos;
CONST
     MaxChrom = 50;       {Maximum population size is 50}
     MaxN     = 200;      {Maximum bit size is 200}
TYPE
     ChromType = RECORD
                   Chr   : ARRAY[1..MaxN] of byte;
                   Fit   : real;
                   Val   : longint;
                   CFit  : real;
                 END;
     ChromPool = ARRAY[1..MaxChrom] of ChromType;
VAR
   I,J,N,Seed,Dis            : integer;
   PopSize,NumGen,Flip,K     : integer;
   Par1,Par2,MaxI,MinI       : integer;
   Pm,AveFit,Pi,start,stop   : real;
   MAXS                      : real;
   A                         : char;
   Best                      : ChromType;
   Pool                      : ARRAY[0..1] of ChromPool;
   OutFile                   : text;
   Dupl                      : BOOLEAN;
   h,m,s,s100,DL             : word;
{* DATAIN-Reads in (from keyboard) basic data for the genetic algorithm *}
PROCEDURE DATAIN;
VAR
   I   : integer;
BEGIN
   ClrScr;
   writeln;
   writeln;
   writeln('          ** Genetic Parameters **');
   writeln;
   write('               ENTER POPULATION SIZE: ');readln(PopSize);
   write('  ENTER THE NUMBER OF BITS IN A GENE: ');readln(N);
   write('         ENTER NUMBER OF GENERATIONS: ');readln(NumGen);
   write('          ENTER MUTATION PROBABILITY: ');readln(Pm);
   write('                   ENTER RANDOM SEED: ');readln(J);
   write('   ENTER YOUR BEST GUESS FOR THE MAX: ');readln(MAXS);
   write('    ENTER THE MINIMUM INTERVAL VALUE: ');readln(MinI);
   write('     ENTER THE MAXMUM INTERVAL VALUE: ');readln(MaxI);
   write('            ENTER THE DISPLAY UPDATE: ');readln(Dis);
   IF (PopSize Mod 2) = 1 THEN PopSize := PopSize + 1;
END;
{** POOLSORT  - Sort the pool of chromsomes in order of fitness **}
PROCEDURE PoolSort(var Chrom:ChromPool);
VAR
   I,J,M1  : integer;
   Max     : real;
   TmpChrom : ChromPool;
   ST       : array[1..MaxChrom] of integer;
BEGIN
   For I:=1 to PopSize Do ST[I] := 0;
   For I:=1 to PopSize DO
      BEGIN
         Max := 0.0;
         For J := 1 to PopSize DO
            BEGIN
               IF (Chrom[J].Fit > Max) and (ST[J] = 0) THEN
                  BEGIN
                     MAX := Chrom[J].Fit;
                     M1 := J;
                  END;
            END;
         ST[M1] := 1;
         TmpChrom[I] := Chrom[M1];
      END;
   For I:=1 to PopSize DO
      Chrom[I] := TmpChrom[I];
END;   {of POOLSORT}
{** BitsToDec  - Converts a binary number to decimal     **}
PROCEDURE BitsToDec(Chrom:ChromType; var Number:longint);
VAR
   i     : integer;
   power : longint;
BEGIN
     Number := 0;
     power := 1;
     For i := N downto 1 do
        BEGIN
           IF Chrom.Chr[i] = 1 then Number := Number + power;
           power := power * 2;
        END;
END;
{**  OPTFUNC-Evaluates function to be optimized. Insert your function here **}
FUNCTION OptFunc(Value:longint) : longint;
VAR
   Temp  :  longint;
BEGIN
     Temp := Value * Value * Value;
     OptFunc := -Temp +  25*Value*Value - 2*Value + 55;
END;
{** INITIALIZE - Generate initial Chromosome Pool        **}
PROCEDURE INITIALIZE(var Chrom:ChromPool; IntStart:integer); 
VAR
   I,J  : integer;
   S,K  : longint;
BEGIN
   Randomize; RandSeed := IntStart;
   FOR I:=1 to PopSize DO
      BEGIN
         REPEAT
            FOR J:=1 to N DO
               BEGIN
                  S:=random(10);
                  IF S > 5 THEN Chrom[I].Chr[J] := 1
                  ELSE Chrom[I].Chr[J] := 0;
               END;
            BitsToDec(Chrom[I],K);
            Chrom[I].Val := OptFunc(K);
         UNTIL (K>=MinI) AND (K<=MaxI);
      END;
   FOR J:=1 to N DO Best.Chr[J] := 0;
   Best.Fit := 0.0;
END;
{**  FITNESS - Determines the fitness of a chromosome pool **}
PROCEDURE Fitness(var Chrom:ChromPool);
VAR
   i         :  integer;
   Value     :  longint;
   CF        :  real;
BEGIN
   CF := 0.0;
   For i:=1 to PopSize DO
      BEGIN
         BitsToDec(Chrom[i],Value);
         Chrom[i].Val := OptFunc(Value);
         Chrom[i].Fit := Abs(Chrom[i].Val/MAXS);
         If Chrom[i].Fit > 1.0 then chrom[i].Fit := 0.01;
         CF := CF + Chrom[i].Fit;
         IF Chrom[i].Fit > Best.Fit THEN
             Best := Chrom[i];
      END;
   AveFit := CF/Popsize;
END;  {of FITNESS}
{** PARENT - Selects a random parent from the pool       **}
FUNCTION PARENT(Chrom:ChromPool):integer;
VAR
   Rnd  : real;
   I    : integer;
BEGIN
   Rnd := random;
   I := 1;
   WHILE Rnd > Chrom[I].CFit DO I := I + 1;
   PARENT := I;
END;
{** MUTATE - randomly complements a bit in the chromosome **}
PROCEDURE MUTATE(var Chrom:ChromType);
VAR
   I : integer;
BEGIN
   FOR I:=1 to N DO
      IF Pm > random THEN Chrom.Chr[I] := 1 - Chrom.Chr[I];
END;
{** SWAP-Randomly swap a bit with its neighbor; halfthe time with its upper **}
{**   neighbor, half the time with its lower neighbor.                      **}
PROCEDURE SWAP(var Chrom:ChromType);
VAR
   TMP,SP : integer;
BEGIN
   SP:=random(N);
   IF SP<2 THEN SP := 2;
   IF SP>(N-1) THEN SP := N-1;
   IF random > 0.5 THEN
      BEGIN
         TMP := Chrom.Chr[SP];
         Chrom.Chr[SP] := Chrom.Chr[SP-1];
         Chrom.Chr[SP-1] := TMP;
      END
   ELSE
      BEGIN
        TMP := Chrom.Chr[SP];
         Chrom.Chr[SP] := Chrom.Chr[SP+1];
         Chrom.Chr[SP+1] := TMP;
      END;
END;
{** CROSSOVER-Standard Crossover function. Selects one random point and **}
{** switches the tales of the two parents                               **}
PROCEDURE CROSSOVER(P1,P2:ChromType;Var C1,C2:ChromType);
VAR
   I,J   :integer;
BEGIN
   I:=random(N);
   IF I=0 THEN I:=1;
   FOR J:=1 to N DO
      IF J < I THEN
         BEGIN
            C1.Chr[J] := P1.Chr[J];
            C2.Chr[J] := P2.Chr[J];
         END
      ELSE
         BEGIN
            C1.Chr[J] := P2.Chr[J];
            C2.Chr[J] := P1.Chr[J];
         END;
END;
{** MERGE-Combine two pools to create a single pool containing best of both **}
PROCEDURE Merge(old:ChromPool;var new:chromPool);
VAR
   I,J,K     : integer;
   Tmp1,Tmp2 : ChromType;
BEGIN
   K:=1;
   J:=1;
   WHILE J < PopSize+1 DO
      BEGIN
         IF old[K].Fit > new[J].Fit THEN
            BEGIN
               Tmp1 := new[J];
               new[J] := old[K];
               K:=K+1;
               IF K > 5 THEN J := PopSize+1;
               FOR I := J+1 to PopSize DO
                  BEGIN
                     Tmp2:=new[I];
                     new[I] := Tmp1;
                     Tmp1:=Tmp2;
                  END;
            END
         ELSE
            J:=J+1;
      END;
 END;
{** DUPLICATE DETECTION/REPLACEMENT-Finds duplicate elements in pool and **}
{** replaces them with new  random elements                              **}
PROCEDURE DupReplace(var Chrom:ChromPool);
VAR
   I,J,K,S   :  integer;
   DP        :  Boolean;
BEGIN
   I := 1;
   K := 1;
   DP := false;
   WHILE K <= PopSize DO
      BEGIN
         IF DP THEN DP := false ELSE K := I+1;
         DP := false;
         J := 1;
         WHILE (J <= N) and (Chrom[I].Chr[J] = Chrom[K].Chr[J]) DO J := J+1;
         IF J > N THEN DP := true;
         IF DP THEN
            BEGIN
               Dupl := true;
               FOR J := 1 to N DO
                  BEGIN
                     S := random(10);
                     IF S > 5 THEN Chrom[K].Chr[J] := 1
                     ELSE Chrom[K].Chr[J] := 0;
                  END;
               K:=K+1;
            END
         ELSE I := K;
      END;
END;               
{** FILE OUTPUT - outputs each generation to a file      **}
PROCEDURE FileOut(Chrom:ChromPool; I:integer);
VAR
   J,K : integer;
BEGIN
   writeln(OutFile,'*****************  GENERATION ',I:3,'*******************');
   writeln(OutFile);
   write(OutFile,'BEST FIT: ');
   FOR J:=1 to N DO write(OutFile,Best.Chr[J]);
   writeln(OutFile,'  Fitness: ',Best.Fit);
   writeln(OutFile,' Average Fit for this generation: ',AveFit);
   writeln(OutFile);
   writeln(OutFIle,'  Elasped Time: ',stop);
   FOR J:=1 to PopSize DO
      BEGIN
         FOR K:=1 to N DO
            write(OutFile,Chrom[J].Chr[K]);
         writeln(OutFile,'  ',Chrom[J].Fit:4:3);
      END;
   writeln(OutFile);
   writeln(OutFile,'********************************************************');
   writeln(OutFile);
END;   {of FILE OUTPUT}
{** SCREEN_WIN - Screen_Win will accept two colors and a row       **} 
{**    location to set up a window for input/output                **}
procedure Screen_Win(x1,x2,y1,y2,fg,bg:integer);
var i,j :byte;
begin
     TextColor(fg);
     TextBackground(bg);
     for i:=x1 to x2 do
         begin
            GotoXY(i,y1);
            write(#205);
            GotoXY(i,y2);
            write(#205)
         end;
     for i:=(y1+1) to (y2-1) do
         begin
              GotoXY(x1,i);
              write(#186);
              GotoXY(x2,i);
              write(#186)
         end;
     GotoXY(x1,y1);
     write(#201);
     GotoXY(x1,y2);
     write(#200);
     GotoXY(x2,y1);
     write(#187);
     GotoXY(x2,y2);
     write(#188);
     for i:=y1+1 to y2-1 do
         for j:=x1+1 to x2-1 do
             begin
                  GotoXY(j,i);
                  Write(' ')
             end;
end;
{**              Start the timer                                  **}
procedure clockon(var startclock : real;var DL:word);
var
   Y,M,DW : word;
Begin
      gettime(h,m,s,s100);
     startclock := (h*3600) + (m*60) + s + (s100/100);
     getdate(Y,M,DL,DW);
end;
{**                Stop the timer                                  **}
procedure clockoff(var stopclock:real; startclock : real; DL:word);
var
    i:integer;
    Y1,M,D,DW:word;
BEGIN
     gettime(h,m,s,s100);
     stopclock:=(h*3600) + (m*60) + s + (s100/100);
     getdate(Y1,M,D,DW);
     if D = DL then
        stopclock:=stopclock - startclock
     else
         stopclock:=(D - DL - 1)*86400 + 86400 - startclock + stopclock;
END;
{** GENERATION OUTPUT-Prints out the current generation and summary data **}
PROCEDURE GENOUT(Chrom : ChromPool;I:integer);
VAR
   J,K,S : integer;
BEGIN
   clockoff(stop,start,DL);
   GoToXY(6,5);   write(stop:5:3);
   GoToXY(19,5);  write(I:4);
   GoToXY(36,5);  write(Best.Fit:5:3);
   GoToXY(50,5);  write(AveFit:5:3);
   GoToXY(62,5);  write(MAXS:7);
   S := N;
   IF N > 64 THEN S:=64;
   GoToXY(6,9);   FOR J:=1 to S DO write(Best.chr[J]);
   IF N > 64 THEN
      BEGIN
         S:=N;
         IF N > 128 THEN S := 128;
         GoToXY(6,10);
         FOR J:=65 to S DO write(Best.chr[J]);
         IF N > 128 THEN
            BEGIN
               S:=N;
               IF N > 192 THEN S:=192;
               GoToXY(6,11);
               For J:=129 to S DO write(Best.chr[J]);
            END;
      END;
   GoToXY(72,9);
   write(Best.Val:6);
   GoToXY(9,16);
   write('Chrom     Value    FIT      Chrom     Value    FIT');
   FOR J:=1 to 6 DO
      BEGIN
         GoToXY(9,16+J);
         write(J:2);
         GoToXY(17,16+J);
         write(Chrom[J].val:6);
         GoToXY(27,16+J);
         write(Chrom[J].Fit:4:3);
         GoToXY(37,16+J);
         write((J+6):2);
         GoToXY(43,16+J);
         write(Chrom[J+6].val:6);
         GoToXY(53,16+J);
         write(Chrom[J+6].Fit:4:3);
      END;
   IF (I mod Dis) = 0 THEN
      BEGIN
         GoToXY(56,2);   write('PAUSE');
         GoToXY(56,3);   write('HIT RETURN . . .');   readln;
         GoToXY(56,2);   write('      ');
         GoToXY(56,3);   write('                ');
      END;
END;
{**  DISPLAY - Sets up the standard screen display                 **}
Procedure SetDisplay;
   BEGIN
        Textbackground(blue);
        Textcolor(white);
        clrscr;
        writeln;
        writeln('                           GENETIC SEARCH');
        writeln;
        Screen_Win(4,14,4,6,yellow,blue);
        GotoXY(6,4);write('TIME');
        Screen_Win(18,31,4,6,yellow,blue);
        GotoXY(20,4); write('Generation');
        Screen_Win(34,46,4,6,yellow,blue);
        GotoXY(36,4); write('Best Fit');
        Screen_Win(48,59,4,6,yellow,blue);
        GotoXY(50,4); write('Ave Fit');
        Screen_Win(61,75,4,6,yellow,blue);
        GoToXY(63,4);write('Target');
        Screen_Win(4,78,8,13,yellow,blue);
        GotoXY(6,8);write('Current Best Point');
        Screen_Win(6,76,15,25,yellow,blue);
        GotoXY(8,15);write('Population Sample');
   END;
{**                M A I N   P R O G R A M               **}
BEGIN
   DATAIN;
   assign(OutFile,'results.txt'); rewrite(OutFile);
   writeln(OutFile,'            GENETIC RUN');
   writeln(OutFile,'  **********   PARAMETERS FOR THIS RUN    ************');
   writeln(OutFile,'     Number of Generations: ',NumGen:3);
   writeln(OutFile,'   Size of Chromosome Pool: ',PopSize:3);
   writeln(OutFile,'      Mutation Probability: ',Pm:4:3);
   writeln(OutFile,'       Random Start Number: ',Seed:5);
   writeln(OutFile,'  ****************************************************');
   writeln(OutFile);
   clockon(start,DL);
   INITIALIZE(Pool[0],Seed);
   FITNESS(Pool[0]);
   PoolSort(Pool[0]);
   SetDisplay;
   GENOUT(Pool[0],0);
   I:=0;
   WHILE (I < NumGen)  DO
      BEGIN
         FLIP := I Mod 2;
         K:=1;
         FOR J:=1 to (PopSize div 2) DO
            BEGIN
               Par1 := Parent(Pool[Flip]);
               Par2 := Parent(Pool[Flip]);
               CROSSOVER(Pool[Flip,Par1],Pool[Flip,Par2],
                         Pool[1-Flip,K],Pool[1-Flip,K+1]);
               K:=K+2;
            END;
         FITNESS(Pool[1-Flip]);
         PoolSort(Pool[1-Flip]);
         Merge(Pool[Flip],Pool[1-Flip]);
         Dupl := false;
         DupReplace(Pool[1-Flip]);
         IF Dupl THEN
            BEGIN
               FITNESS(Pool[1-Flip]);
               PoolSort(Pool[1-Flip]);
            END;
         FileOut(Pool[1-Flip],I+1); 
         GENOUT(Pool[1-Flip],I+1);
         I := I+1;
      END;
   GoToXY(56,2);   write('DONE');
   GoToXY(56,3);   write('HIT RETURN . . .'); readln;
   close(OutFile);
END.




[LISTING TWO]

{** INVERSION - Change the order of bits between two random **}
{**   points - 100(10110)0110 becomes 100(01101)0110        **}
PROCEDURE INVERSION(var Chrom:ChromType);
VAR
   I,K,S1,S2,Tmp   : integer;
BEGIN
   IF random < Pi THEN
      BEGIN
         S1 := random(N-1);
         IF S1=0 THEN S1:=1;
         S2 := random(N);
         WHILE S2 = S1 DO
             S2 := random(N);
         IF S2=0 THEN S2:=1;
         IF S1 > S2 THEN
            BEGIN
               Tmp := S2;
               S2 := S1;
               S1 := Tmp;
            END;
         K := (S2 - S1 + 1) DIV 2;
         FOR I:=1 TO K DO
            BEGIN
               Tmp := Chrom.Chr[I+S1-1];
               Chrom.Chr[I+S1-1] := Chrom.Chr[S2-I+1];
               Chrom.Chr[S2+1-I] := Tmp;
            END;
      END;
END;