unit GADelphi;
interface
uses
  Math, SysUtils;

type

  PUnsigned = array of Cardinal;

  Pint = ^integer;
  individual = record
    chrom: PUnsigned;
    fitness: double;
    varible: double;
    xsite: integer;
    parent: array[0..1] of integer;
    utility: Pint;
  end;

  bestever = record
    chrom: PUnsigned;
    fitness: Double;
    varible: Double;
    generation: Integer;
  end;
  //* 隨機數發生器使用的靜態變量 */

  TGA = class(Tobject)
  public
    oldpop, temp, newpop: array of individual;
    bestfit: bestever;
    sumfitness: double;
    max, avg, min: double;
    pcross, pmutation: single;
    popsize, lchrom, chromsize, gen, maxgen, run, maxruns: integer;
    printstrings: integer; //* 輸出染色體編碼的判斷，0 -- 不輸出, 1 -- 輸出 */
    nmutation: integer; //* 當前代變異發生次數 */
    ncross: integer;
    procedure initpop;
    procedure objfunc(var critter: individual);
    function flip(prob: single): boolean;
    function select: integer;
    function crossover(var parent1, parent2, child1, child2: PUnsigned): integer;
    function rnd(low, high: integer): integer;
    procedure mutation(child: PUnsigned);
    procedure generation;
    procedure preselect;
    constructor Create;
    procedure initdata;
    procedure initmalloc;
    procedure statistics(pop: array of individual);
    procedure initreport;
    procedure skip(skipcount: integer);
    procedure Go;
    procedure report;
    procedure repchar(ch: pchar; repcount: integer);
    procedure writepop;
    procedure writechrom(chrom: PUnsigned);
    procedure GARandomize;
    procedure advance_random;
    function randomperc: single;
    function randomnormaldeviate: double;
    procedure warmup_random(random_seed: single);
  end;

implementation
var
  oldrand: array[0..54] of double;
  jrand: integer;
  rndx2: double;
  rndcalcflag: integer;

procedure TGA.GARandomize; // * 設定隨機數種子并初始化隨機數發生器 * /
var
  randomseed: single;
  j1: integer;
begin
  for j1 := 0 to 54 do
    oldrand[j1] := 0.0;
  jrand := 0;
  repeat
    write('隨機數種子[0 - 1]: ');
    readln(randomseed);
  until not ((randomseed < 0.0) and (randomseed > 1.0));
  warmup_random(randomseed);
end;

procedure TGA.warmup_random(random_seed: single); // * 初始化隨機數發生器 * /
var
  j1, ii: integer;
  new_random, prev_random: double;
begin
  oldrand[54] := random_seed;
  new_random := 0.000000001;
  prev_random := random_seed;
  for j1 := 1 to 54 do
  begin
    ii := (21 * j1) mod 54;
    oldrand[ii] := new_random;
    new_random := prev_random - new_random;
    if (new_random < 0.0) then
      new_random := new_random + 1.0;
    prev_random := oldrand[ii];
  end;
  advance_random;
  advance_random();
  advance_random();
  jrand := 0;
end;

procedure TGA.advance_random; //* 產生55個隨機數 */
var
  j1: integer;
  new_random: double;
begin
  for j1 := 0 to 23 do
  begin
    new_random := oldrand[j1] - oldrand[j1 + 31];
    if (new_random < 0.0) then
      new_random := new_random + 1.0;
    oldrand[j1] := new_random;
  end;
  for j1 := 24 to 54 do
  begin
    new_random := oldrand[j1] - oldrand[j1 - 24];
    if (new_random < 0.0) then new_random := new_random + 1.0;
    oldrand[j1] := new_random;
  end;
end;

function TGA.randomnormaldeviate: double; //* 產生隨機標準差 */
var
  t, rndx1: double;
begin

  if rndcalcflag = 1 then
  begin
    rndx1 := sqrt(-2.0 * log2(randomperc));
    t := 6.2831853072 * randomperc;
    rndx2 := rndx1 * sin(t);
    rndcalcflag := 0;
    result := (rndx1 * cos(t));
  end
  else
  begin
    rndcalcflag := 1;
    result := (rndx2);
  end;
end;

function TGA.randomperc: single;
  //*與庫函數random()作用相同, 產生[0,1]之間一個隨機數 */
begin
  inc(jrand, 1);
  if (jrand >= 55) then
  begin
    jrand := 1;
    advance_random();
  end;
  result := oldrand[jrand];
end;

constructor TGA.Create; //* 遺傳算法初始化 */
begin
     //* 鍵盤輸入遺傳算法參數 */
  initdata;
    //* 確定染色體的字節長度 */
  chromsize := (lchrom div (8 * sizeof(cardinal)));
  if ((lchrom mod (8 * sizeof(cardinal))) = 0) or (lchrom < (8 *
    sizeof(cardinal)))  then
    inc(chromsize, 1);
    //*分配給全局數據結構空間 */
  initmalloc;
    //* 初始化隨機數發生器 */
  GArandomize;
    //* 初始化全局計數變量和一些數值*/
  nmutation := 0;
  ncross := 0;
  bestfit.fitness := 0.0;
  bestfit.generation := 0;
    //* 初始化種群，并統計計算結果 */
  initpop;
  statistics(oldpop);
  initreport;
end;

procedure TGA.initreport; //* 初始參數輸出 /*
begin
  skip(1);
  writeln('             基本遺傳算法參數\n');
  writeln(' -------------------------------------------------');
  writeln(format(' 種群大小(popsize) = %d', [popsize]));
  writeln(format(' 染色體長度(lchrom) = %d', [lchrom]));
  writeln(format(' 最大進化代數(maxgen) = %d', [maxgen]));
  writeln(format(' 交叉概率(pcross) = %8.6f', [pcross]));
  writeln(format(' 變異概率(pmutation) = %8.6f', [pmutation]));
  writeln(' -------------------------------------------------');
  skip(1);

end;

procedure TGA.skip(skipcount: integer);
var j: integer;
begin
  for j := 1 to skipcount do
    writeln;
end;

procedure TGA.statistics(pop: array of individual); //* 計算種群統計數據 */
var
  i, j: integer;
begin
  sumfitness := 0.0;
  min := pop[0].fitness;
  max := pop[0].fitness;
    //* 計算最大、最小和累計適應度 */
  for j := 0 to popsize - 1 do
  begin
    sumfitness := sumfitness + pop[j].fitness;
    if (pop[j].fitness > max) then
      max := pop[j].fitness;
    if (pop[j].fitness < min) then
      min := pop[j].fitness;
    // * new global best - fit individual * /
    if (pop[j].fitness > bestfit.fitness) then
    begin
      for i := 0 to chromsize - 1 do
        bestfit.chrom[i] := pop[j].chrom[i];
      bestfit.fitness := pop[j].fitness;
      bestfit.varible := pop[j].varible;
      bestfit.generation := gen;
    end;
  end;
  // * 計算平均適應度 * /
  avg := sumfitness / popsize;
end;

procedure TGA.initmalloc;
var
  nbytes: cardinal;
  j: integer;
begin
//  char  *malloc();
  //* 分配給當前代和新一代種群內存空間 */
 // nbytes = popsize * sizeof(individual);
{  if((oldpop = (struct individual *) malloc(nbytes)) == NULL)
    nomemory("oldpop")}
  setlength(oldpop, popsize);
  setlength(newpop, popsize);
{  if((newpop = (struct individual *) malloc(nbytes)) == NULL)
    nomemory("newpop");}
  //* 分配給染色體內存空間 */
//  nbytes = chromsize * sizeof(unsigned);
  for j := 0 to popsize - 1 do
  begin
    {  if((oldpop[j].chrom = (unsigned *) malloc(nbytes)) == NULL)
 nomemory("oldpop chromosomes");}
    SetLength(oldpop[j].chrom, chromsize);
    SetLength(newpop[j].chrom, chromsize);
    {  if((newpop[j].chrom = (unsigned *) malloc(nbytes)) == NULL)
 nomemory("newpop chromosomes");}
  end;
  SetLength(bestfit.chrom, chromsize);


end;

procedure TGA.initdata; //* 遺傳算法參數輸入 */
var
  answer: array[0..1] of char;
begin
  writeln('種群大小(20-100)：');
  readln(popsize);
  if ((popsize mod 2) <> 0) then
  begin
    writeln('種群大小已設置為偶數');
    inc(popsize, 1);
  end;
  writeln('染色體長度(8-40)：');
  readln(lchrom);
  writeln('是否輸出染色體編碼(y/n)');
  printstrings := 1;
  readln(answer);
  if (comparetext(answer, 'n') = 0) then
    printstrings := 0;
  writeln('最大世代數(100 - 300)：');
  readln(maxgen);
  writeln('交叉率(0.2 - 0.9)：');
  readln(pcross);
  writeln('變異率(0.01 - 0.1)：');
  readln(pmutation);
end;

procedure TGA.initpop;
var
  j, j1, k, stop: integer;
  mask: Cardinal;
begin
  mask := 1;
  for j := 0 to popsize - 1 do
  begin
    for k := 0 to chromsize - 1 do
    begin
      oldpop[j].chrom[k] := 0;
      if k = chromsize - 1 then
        stop := lchrom - (k * (8 * sizeof(cardinal)))
      else
        stop := 8 * sizeof(cardinal);
      for j1 := 1 to stop do
      begin
        oldpop[j].chrom[k] := oldpop[j].chrom[k] shl 1;
        if flip(0.5) then
          oldpop[j].chrom[k] := oldpop[j].chrom[k] or mask;
      end;
      oldpop[j].parent[0] := 0;