gadelphi.pas

关于加气站的遗传算法实现

   for k:= 0 to SPNum-1 do
   begin
     StationDemand :=0;
     StationCost :=0;
     i:= SplitString(MyGenes[SPArray[k]].Supplypoint,',');
     for j:=0 to i-1 do
     begin
       StationDemand :=StationDemand + MyGenes[Supplypoint[j]].Demand;
     end;

     if StationDemand <= 2000 then
     begin
        StationCost:= 1800000;
        totalSupply :=  totalSupply+2000;
     end
     else if StationDEmand <= 4000 then
     begin
         StationCost:= 3500000 ;
         totalSupply :=  totalSupply+4000 ;
     end
     else if StationDEmand <= 10000 then
     begin
         StationCost:= 5500000;
         totalSupply :=  totalSupply+10000 ;
     end
     else
         StationCost:= 1E+10;
     totalStationCost:=  totalStationCost + StationCost;
   end;
   //计算距离和时间费用
   TimeAndDisCost :=0;
   for j:= 0 to lchrom -1 do
   begin
     timeAndDisCost:=TimeAndDisCost + (MyGenes[j].Demand/Q)*(MyGenes[j].Distance*g*p + MyGenes[j].Distance*k/V );
   end;
   //if totalsupply >= totalDemand then
   critter.fitness := -1*(totalStationCost + TimeAndDisCost)
   //else
     // critter.fitness:=1000000000000;
  //////2005-4-1 Add---------------------
end;


function TGA.flip(prob: single): boolean; // 以一定概率产生0或1
begin
  if (randomperc <= prob) then
    result := true
  else
    result := false;
end;

function TGA.select: integer; //* 轮盘赌选择*/
var
  sum, pick: single;
  i: integer;
begin
  pick := randomperc;
  sum := 0;
  i := 0;
  if (sumfitness <> 0) then
    while ((sum < pick) and (i < popsize)) do
    begin
      sum := sum + oldpop[i].fitness / sumfitness;
      inc(i);
    end
  else
    i := rnd(1, popsize);
  result := i - 1;
end;

function TGA.rnd(low, high: integer): integer;
  //*在整数low和high之间产生一个随机整数*/
var
  i: integer;
begin
  if (low >= high) then
    i := low
  else
  begin
    i := trunc((randomperc * (high - low + 1)) + low);
    if (i > high) then
      i := high;
  end;
  result := i;
end;

function TGA.crossover(var parent1, parent2, child1, child2: PUnsigned): integer;
  // * 由两个父个体交叉产生两个子个体 * /
var
  j, jcross, k: integer;
  mask, temp: cardinal;
begin
  if (flip(pcross)) then
  begin
    jcross := rnd(1, (lchrom - 1)); // * Cross between 1 and l - 1 * /
    inc(ncross, 1);
    for k := 1 to chromsize do
    begin
      if (jcross >= (k * (8 * sizeof(cardinal)))) then
      begin
        child1[k - 1] := parent1[k - 1];
        child2[k - 1] := parent2[k - 1];
      end
      else
        if ((jcross < (k * (8 * sizeof(cardinal)))) and (jcross > ((k - 1) * (8 *
          sizeof(cardinal))))) then
        begin
          mask := 1;
          for j := 1 to jcross - 1 - ((k - 1) * (8 * sizeof(cardinal))) do
          begin
            temp := 1;
            mask := mask shr 1;
            mask := mask and temp;
          end;
          child1[k - 1] := (parent1[k - 1] and mask) or (parent2[k - 1] and (not
            mask));
          child2[k - 1] := (parent1[k - 1] and (not mask)) or (parent2[k - 1] and
            mask);
        end
        else
        begin
          child1[k - 1] := parent2[k - 1];
          child2[k - 1] := parent1[k - 1];
        end;
    end;
  end
  else
  begin
    for k := 0 to chromsize - 1 do
    begin
      child1[k] := parent1[k];
      child2[k] := parent2[k];
    end;
    jcross := 0;
  end;
  result := jcross;
end;

procedure TGA.mutation(child: PUnsigned); //*变异操作*/
var
  j, k, stop: integer;
  mask, temp: cardinal;
begin
  temp := 1;
  for k := 0 to chromsize - 1 do
  begin
    mask := 0;
    if (k = (chromsize - 1)) then
      stop := lchrom - (k * (8 * sizeof(cardinal)))
    else
      stop := 8 * sizeof(cardinal);
    for j := 0 to stop - 1 do
    begin
      if (flip(pmutation)) then
      begin
        mask := mask or (temp shl j);
        inc(nmutation, 1);
      end;
    end;
    child[k] := child[k] xor mask;
  end;
end;

procedure TGA.generation;
var
  mate1, mate2, jcross, j: integer;
begin
  j := 0;
  //*  每代运算前进行预选 */
  preselect;
  //* 选择, 交叉, 变异 */
  repeat
      //* 挑选交叉配对 */
    mate1 := select();
    mate2 := select();
      //* 交叉和变异 */
    jcross := crossover(oldpop[mate1].chrom, oldpop[mate2].chrom, newpop[j].chrom,
      newpop[j + 1].chrom);
    mutation(newpop[j].chrom);
    mutation(newpop[j + 1].chrom);
      //* 解码, 计算适应度 */
    objfunc(newpop[j]);
      //*记录亲子关系和交叉位置 */
    newpop[j].parent[0] := mate1 + 1;
    newpop[j].xsite := jcross;
    newpop[j].parent[1] := mate2 + 1;
    objfunc(newpop[j + 1]);
    newpop[j + 1].parent[0] := mate1 + 1;
    newpop[j + 1].xsite := jcross;
    newpop[j + 1].parent[1] := mate2 + 1;
    j := j + 2;
  until (j >= (popsize - 1));
end;

procedure TGA.preselect;
var
  j: integer;
begin
  sumfitness := 0;
  for j := 0 to popsize - 1 do
    sumfitness := sumfitness + oldpop[j].fitness;
end;

procedure TGA.Go;
begin
  writeln('---------------------------------');
  writeln('       CNG加气站选址算法');
  writeln('---------------------------------');
  writeln('开始计算，请等待！！！');
  gen := 1;
  while (gen < maxgen) do
  begin
      //fprintf(outfp, "\n第 %d / %d 次运行: 当前代为 %d, 共 %d 代\n", run, maxruns,
        //gen, maxgen);
      // * 产生新一代 * /
    generation;
      // * 计算新一代种群的适应度统计数据 * /
    statistics(newpop);
      // * 输出新一代统计数据 * /
    report;

    temp := copy(oldpop);
    oldpop := copy(newpop);
    newpop := copy(temp);
    inc(gen, 1);
  end;
  closefile(FResult);
 write('计算完成，赶快去看看结果吧，在文本文件result中！！！\n') ;
//  freeall();
end;

procedure TGA.repchar(ch: pchar; repcount: integer);
var
  j: integer;
begin
  for j := 1 to repcount - 1 do
    write(FResult, ch);

end;

procedure TGA.report; //* 输出种群统计结果 */

begin
  repchar('-', 80);
  writeln(FResult, '');
  skip(1);
  if (printstrings = 1) then
  begin
    repchar(' ', ((80 - 17) div 2));
    writeln(FResult, '模拟计算统计报告  ');
    write(FResult, '世代数 ', gen);
    repchar(' ', (80 - 28));
    write(FResult, '世代数 ', (gen + 1));
    writeln(FResult, '');
    write(FResult, '个体  染色体编码');
    repchar(' ', lchrom - 5);
    write(FResult, '适应度    父个体 交叉位置  ');
    write(FResult, '染色体编码 ');
    repchar(' ', lchrom - 5);
    write(FResult, '适应度');
    writeln(FResult, '');
    repchar('-', 80);
    writeln(FResult, '');
    skip(1);
    writepop();
    repchar('-', 80);
    writeln(FResult, '');
    skip(1);
  end;
  writeln(FResult, format('第 %d 代统计: ', [gen]));
  writeln(FResult, '总交叉操作次数 = ', ncross, ' 总变异操作数 = ', nmutation);
  writeln(FResult, ' 最小适应度：', min, ' 最大适应度：', max, '  平均适应度 %f', avg);
  writeln(FResult, format(' 迄今发现最佳个体 =>  所在代数： %d  ', [bestfit.generation]));
  writeln(FResult, ' 适应度： ', bestfit.fitness);
   writeln(FResult, '  染色体：');
  writechrom(bestfit.chrom);

  skip(1);
  reportsupplypoint(bestfit.chrom);
  repchar( '-', 80);
  writeln(FResult, '');
  skip(1);
end;

procedure TGA.writepop;
var
  pind: individual;
  j: integer;
begin
  for j := 0 to popsize - 1 do
  begin
    write(FResult, format('%3d)  ',[j + 1]));
        //* 当前代个体 */
    pind := oldpop[j];
    writechrom(pind.chrom);
    write(FResult, format('  %8f | ', [pind.fitness]));
        //* 新一代个体 */
    pind := newpop[j];
    write(FResult, format('(%2d,%2d)   %2d   ', [pind.parent[0], pind.parent[1],
      pind.xsite]));
    writechrom(pind.chrom);
    writeln(FResult, format('  %8f  ', [pind.fitness]));
  end;
end;

procedure TGA.writechrom(chrom: PUnsigned); //* 输出染色体编码 */
var
  j, k, stop: integer;
  mask, tmp: Cardinal;
begin
  mask := 1;
  for k := 0 to chromsize - 1 do
  begin
    tmp := chrom[k];
    if (k = (chromsize - 1)) then
      stop := lchrom - (k * (8 * sizeof(cardinal)))
    else
      stop := 8 * sizeof(cardinal);
    for j := 0 to stop - 1 do
    begin
      if (tmp and mask) = 1 then
        write(FResult, '1')
      else
        write(FResult, '0');
      tmp := tmp shr 1;
    end;
  end;
end;
function TGA.SplitString(const Source,ch:string):integer;
var
        temp:String;
        temp2:TStringList;
        i:Integer;
begin
        temp2:=TStringList.Create;
//如果是空自符串则返回空列表
        if Source=''
                then exit;
        temp:=Source;
        i:=pos(ch,Source);
        while i<>0 do
        begin
                temp2.add(copy(temp,0,i-1));
                Delete(temp,1,i);
                i:=pos(ch,temp);
        end;
        temp2.add(temp);
        for i:=0 to temp2.Count-1 do
        begin
                supplypoint[i]:=strtoint(temp2[i]);
        end;
        result := temp2.Count;
end;

procedure TGA.reportsupplypoint(var critter: PUnsigned);
var
  mask, bitpos, tp: cardinal;
  bitpow: double;
  i,j, k, stop: integer;

//////2005-4-1 Add---------------------
  DPArray: array of integer;  //一个染色体中需求点的下标数组
  SPArray: array of integer; //一个染色体中供应点的下标数组
  DPNum,SPNum:  integer;//  一个染色体中需求点和供应点 的个数
  tmpDistance,tmpx,tmpy,tmpDistance2: single;//
  sp:integer; //某一需求点的供应点的下标
  stationdemand:double;
begin
  DPNum :=0;
  SPNum :=0;
    setlength(DPArray,lchrom);
  setlength(SPArray,lchrom);

  /////2005-4-1 Add---------------------
  mask := 1;

  for k:=0 to lchrom-1 do
  begin
      mygenes[k].DPorSP :=0;
      mygenes[k].Distance :=0;
      mygenes[k].Supplypoint := '';
  end;
  for k := 0 to chromsize - 1 do
  begin
    if (k = (chromsize - 1)) then
      stop := lchrom - (k * (8 * sizeof(cardinal)))
    else
      stop := 8 * sizeof(cardinal);
    tp := critter[k];

    for j := 0 to stop - 1 do
    begin
      bitpos := j + (8 * sizeof(cardinal)) * k;
      if ((tp and mask) = 1) then
      begin
   //////2005-4-1 Add---------------------
        Mygenes[bitpos].DPorSP := 1;
        SPArray[SPNum] := bitpos ;
        SPNum := SPnum +1
      end
      else
      begin
        Mygenes[bitpos].DPorSP := 0;
        DPArray[DPNum] := bitpos;
        DPNum := DPnum +1;
      end;
      tp := tp shr 1;
    end;
  end;

  //对供应点设置距离为0，被供应的点加上本站。
  for j:=0 to SPNum -1 do
  begin
     MyGenes[SPArray[j]].Distance :=0;
     MyGenes[SPArray[j]].Supplypoint:= MyGenes[SPArray[j]].Supplypoint + inttostr(SPArray[j]+1);
  end;

  //对需求点求解他的供应点和距离；
  for j:=0 to DPNum -1 do
  begin
     sp:=-1;
     tmpDistance :=1.0E+10;
     for k := 0 to SPNum-1 do
     begin
       tmpX := power(Mygenes[SPArray[k]].x - Mygenes[DPArray[j]].x, 2) ;
       tmpY := power(Mygenes[SPArray[k]].y - Mygenes[DPArray[j]].y, 2) ;
       tmpDistance2 := sqrt(tmpX + tmpY);
       if (tmpDistance > tmpDistance2) then
       begin
         tmpDistance :=tmpDistance2;
         sp := SPArray[k];
       end;
     end;
     Mygenes[DPArray[j]].Distance := tmpDistance;
     Mygenes[sp].Supplypoint:=Mygenes[sp].Supplypoint +',' + IntToStr(DPArray[j]+1);
  end;

  for j:=0 to SPNum -1 do
  begin
    write(FResult,format(' 第[%d]个站的供应点为： %s :::', [j+1,Mygenes[SPArray[j]].supplypoint]));

     StationDemand :=0;

     i:= SplitString(MyGenes[SPArray[j]].Supplypoint,',');
     for k:=0 to i-1 do
     begin
       StationDemand :=StationDemand + MyGenes[Supplypoint[k]-1].Demand;
     end;

     if StationDemand <= 2000 then
     begin
        write(FResult, '建站规模为移动站：：：：建站成本为180万元');
     end
     else if StationDEmand <= 4000 then
     begin
        write(FResult, '建站规模为子站：：：：建站成本为350万元');
     end
     else if StationDEmand <= 10000 then
     begin
                write(FResult, '建站规模为常规站：：：：建站成本为550万元');
     end
     else
        write(FResult, '规模过大，不可能建站::::建站成本为无穷大');
     writeln(FResult,' ');
  end;
end;
end.