covrp_ga_good9.dpr

OVRP问题的遗传算法研究实现

       p[m]:=f[m]/sum;



     {*随机轮盘赌，直至生成pop_n-1 个子代*}
     m:=low(pop)+1;
     u:=low(poptemp);
     repeat
        if p[u]>Random then
           begin
              pop[m].route:=copy(poptemp[u].route);
              pop[m].sum_ec:=poptemp[u].sum_ec;
              pop[m].sum_cost:=poptemp[u].sum_cost;
              pop[m].sum_k:=poptemp[u].sum_k;
              pop[m].adapt:=poptemp[u].adapt;
              inc(m);
           end;
        inc(u);
        if u=(high(p)+1) then u:=low(p);
     until m=(high(pop)+1);
     {*最佳个体保留*}
     pop[0].route:=copy(best.best_route);
     pop[0].sum_ec:=0;

     pop[0].sum_cost:=best.best_cost;
     pop[0].sum_k:=best.best_k;
   end;



   {快速排序}
   procedure   QuickSort(var   SortNum:array   of   integer;p,r:integer);
      procedure   swap(var   a,b:integer);       //交换
      var   tmp:integer;
      begin
          tmp:=a;
          a:=b;
          b:=tmp;
      end;
      function   partition(var   SortNum:array   of   integer;p,r:integer):integer;   //划分
      var   i,j,x:integer;
      begin
          i:=p;j:=r+1;
          x:=SortNum[p];
          while   true   do
          begin
              repeat   inc(i)
              until   SortNum[i]<x;
              repeat   inc(j,-1)
              until   SortNum[j]>x;
              if   i>=j   then   break;
              swap(SortNum[i],SortNum[j]);
          end;
          SortNum[p]:=SortNum[j];
          SortNum[j]:=x;
          result:=j;
      end;
  var   q:integer;
  begin
      if   p<r   then
      begin
          q:=partition(SortNum,p,r);
          QuickSort(SortNum,p,q-1);
          QuickSort(SortNum,q+1,r);
      end;
  end;

     {*繁殖程序,排序选择加精英个体保留*}
   procedure Reproduce2(var pop : array of solution_rec;const punish_M:double);
   var
     m,u: integer;
     num:array of integer;
     f,p: array of double;
     q1,q2: extended;
     u2:double;
     poptemp:array of solution_rec;
     flagtemp1:boolean;
   begin
     {*把当前种群的数据拷贝到暂存种群*}
     setlength(poptemp,length(pop));
     for m:=low(poptemp) to high(poptemp) do
       begin
         setlength(poptemp[m].route,best.best_k+n);
         poptemp[m].route:=copy(pop[m].route);
         poptemp[m].sum_ec:=pop[m].sum_ec;
         poptemp[m].sum_cost:=pop[m].sum_cost;
         poptemp[m].sum_k:=pop[m].sum_k;
         poptemp[m].adapt:=pop[m].adapt;
       end;
     {*计算适应度函数*}
     setlength(f,length(pop));
     setlength(p,length(pop)+1);


     for m:=low(poptemp) to high(poptemp) do
        begin
         f[m]:=poptemp[m].sum_cost+punish_M*poptemp[m].sum_ec;
         poptemp[m].adapt:=1/f[m];


        end;

      setlength(num,length(pop));

      for m:=low(num) to high(num) do

         num[m]:=m;

      Sortt(f,num);
     {*计算pi*}
      q2:=0.1;
      q1:=q2/(1-power(1-q2,pop_n));
      p[0]:=0;
      for m:=(low(p)+1) to (high(p)-1) do
        p[m]:= q1*power(1-q2,m-1)+p[m-1];

      p[high(p)]:=1;









     {*随机轮盘赌，直至生成pop_n-1 个子代*}
    randomize;
 for u:=low(pop)+1 to high(pop) do
     begin

       u2:=random;
       m:=low(p);
       flagtemp1:=false;
       repeat
          if  (p[m] < u2) and (u2< p[m+1]) then
              begin
                pop[u].route:=copy(poptemp[num[m]].route);
                pop[u].sum_ec:=poptemp[num[m]].sum_ec;
                pop[u].sum_cost:=poptemp[num[m]].sum_cost;
                pop[u].sum_k:=poptemp[num[m]].sum_k;
                pop[u].adapt:=poptemp[num[m]].adapt;
                flagtemp1:=true;
              end
              else inc(m);
       until flagtemp1;
     end;
     {*最佳个体保留*}
     pop[0].route:=copy(best.best_route);
     pop[0].sum_ec:=0;

     pop[0].sum_cost:=best.best_cost;
     pop[0].sum_k:=best.best_k;
   end;
   {*从小到大冒泡排序程序*}
   procedure sort1(var a :array of integer);
   var
     i,j,temp:integer;
     flag:boolean;
   begin
      i:=1;
      repeat
           flag:=true;
           for j:=low(a) to (high(a)-i) do
              if a[j]>a[j+1]
              then begin
                      temp:=a[j];
                      a[j]:=a[j+1];
                      a[j+1]:=temp;
                      flag:=false;
                   end;
           i:=i+1;
      until flag;
   end;



   {*交叉算子A*}
   procedure CrossA(var a1,a2: array of integer;const crossAint:integer);
   var
     m,u1,u2:integer;
     temp1,temp2:array of integer;
   begin
        if check =1 then
        begin
        Append(result);
        u2:=high(a1);
        writeln(result);
        for u1:=0 to  u2 do
              write(result,a1[u1]:4);
        writeln(result);
        u2:=high(a2);
        for u1:=0 to  u2 do
              write(result,a2[u1]:4);
        writeln(result);
        closefile(result);
        end;

     u1:=low(a1)+1;
     for m:=low(a1) to high(a1) do
        if a1[m]=0  then
           begin
             a1[m]:=u1+pop_n;
             inc(u1);
           end;

     u1:=low(a2)+1;
     for m:=low(a2) to high(a2) do
        if a2[m]=0  then
           begin
             a2[m]:=u1+pop_n;
             inc(u1);
           end;

     Randomize;
     u1:=RandomRange(low(a1),high(a1)-crossAint)+1;
     setlength(temp1,crossAint);
     setlength(temp2,crossAint);
     for m:=low(temp1) to high(temp1) do
       temp1[m]:=a1[u1+m]; {*把A1中要替换元素的值放入temp1*}
     for m:=low(temp2) to high(temp2) do
       begin
         for u2:=(low(a2)+1) to high(a2) do
           begin

             if (a2[u2]=temp1[m]) then
              begin

               temp2[m]:=u2;{*把在A2中找到的要替换元素的编号存入temp2*}
               break;
              end;
           end;

       end;
     {*将temp2从小到大冒泡排序*}
     sort1(temp2);
     {*生成子代*}
     for u2:=0 to (crossAint-1) do
       begin
          A1[u1+u2]:=A2[temp2[u2]];
          A2[temp2[u2]]:=temp1[u2];
       end;
     for m:=low(a1) to high(a1) do
        if a1[m]>n  then

             a1[m]:=0;




     for m:=low(a2) to high(a2) do
        if a2[m]>n  then

             a2[m]:=0;


   
   end;
   {交叉算子A2*}
   procedure CrossA2(var a1,a2: array of integer;const crossAint:integer);
   var
     m,u1,u2:integer;
     temp1,temp2,temp3:array of integer;
     flagtemp:boolean;
   begin
        if check =1 then
        begin
        Append(result);
        u2:=high(a1);
        writeln(result);
        for u1:=0 to  u2 do
              write(result,a1[u1]:4);
        writeln(result);
        u2:=high(a2);
        for u1:=0 to  u2 do
              write(result,a2[u1]:4);
        writeln(result);
        closefile(result);
        end;


     Randomize;
     u1:=RandomRange(low(a1),high(a1)-crossAint)+1;
     setlength(temp1,crossAint);
     setlength(temp2,crossAint);
     setlength(temp3,crossAint);
     for m:=0 to (crossaint-1) do
        repeat
          flagtemp:=false;
          u2:= ((u1+m) mod high(a1))+1;
          if a1[u2]>0 then
              begin
                 temp3[m]:=a1[u2]; {*把A1中要替换元素的值放入temp1*}
                 temp1[m]:=u2;
                 flagtemp:=true;
              end
                      else inc(u1);
          until flagtemp;






     for m:=low(temp2) to high(temp2) do
       begin
         for u2:=(low(a2)+1) to high(a2) do
           begin

             if (a2[u2]=temp3[m]) then
              begin

               temp2[m]:=u2;{*把在A2中找到的要替换元素的编号存入temp2*}
               break;
              end;
           end;

       end;
     {*将temp2,temp1从小到大冒泡排序*}
     sort1(temp2);
     sort1(temp1);
     for  m:=low(temp1) to high(temp1) do
        temp3[m]:=A1[temp1[m]];
     {*生成子代*}
     for u2:=0 to (crossAint-1) do
       begin
          A1[temp1[u2]]:=A2[temp2[u2]];
          A2[temp2[u2]]:=temp3[u2];
       end;



     
   end;

   {**贪婪变异子程序*}

   procedure downMutation(var s2:solution_rec;var flagtemp6: boolean);
   var
     u1,u2,u3,temp1:integer;
     s3:solution_rec;
   begin
     setlength(s3.route, length(s2.route));
     s3:=s2;
     u3:=0;
     flagtemp6:=false;
     randomize;
     repeat
      repeat
         u1:=Randomrange(low(s2.route)+1,high(s2.route)-1); {**第一个点不参加交换*}
         u2:=u1+1;
      until ((u1<>u2)and (s2.route[u1]*s2.route[u2]>0));
      temp1:=s3.route[u1];
      s3.route[u1]:=s3.route[u2];
      s3.route[u2]:=temp1;
      Sum_solution(s3.route,s3.sum_cost,s3.sum_ec,s3.adapt,s3.sum_k);
      if s3.adapt>s2.adapt then
          begin
             s2:=s3;
             flagtemp6:=true;
             break;
          end
             else begin
                    s3.route[u2]:=s2.route[u2];
                    s3.route[u1]:=s2.route[u1];
                    inc(u3);
                  end;
     until u3>40;

   end;
    {**简单变异*}
   procedure Mutation(var a:array of integer);
   var
     u1,u2,temp1,temp2,u3:integer;
   begin
      Randomize;
      u3:=Randomrange(1,6);
      for temp2:=0 to u3 do
      begin
      repeat
         u1:=Randomrange(low(a)+1,high(a)); {**第一个点不参加交换*}
         u2:=Randomrange(low(a)+1,high(a));
      until u1<>u2;
      temp1:=a[u1];
      a[u1]:=a[u2];
      a[u2]:=temp1;
      end;
   end;

    {贪婪变异}
   procedure downMutation2(var s4:solution_rec);
   var
     adv_time:integer;
     flagadv_s:boolean;
   begin
      adv_time:=0;
      repeat
        downMutation(s4,flagadv_s);
        if flagadv_s then adv_time:=0
                     else adv_time:=adv_time+1;
      until adv_time > 30;
   end;




   Function pcfunction(f1,f2:double):double;
   var
   f3:double;
   begin
      if f1>f2 then f3:=f1
               else f3:=f2;
      if f3<adaptavg then Result:=0.9
                     else Result:=0.6*(adaptmax-f3)/(adaptmax-adaptavg);
   end;

    Function pmfunction(f1:double):double;

   begin

      if f1<adaptavg then Result:=0.05
                     else Result:=0.5*(adaptmax-f1)/(adaptmax-adaptavg);
   end;


   {*单亲遗传算子*}
   procedure singlecrosser(VAR s3:solution_rec);
   var
     u1,u2,u3,u4:integer;
   begin
     Randomize;
     u3:=round(length(s3.route)/s3.sum_k)-2;
     for u4:=0 to u3 do
     begin
       repeat
         u1:=Randomrange(low(s3.route)+1,high(s3.route));
         u2:=Randomrange(low(s3.route)+1,high(s3.route));
       until ((Abs(u1-u2))>0) or (s3.route[u1]*s3.route[u1]>0);
     end;
   end;