unitfp.pas

一个多元非线性回归分析源码以及其中的公式列表

    end
    else
    begin
      REAgainValue:=sumAgain;
      REAgain:=0;
    end;
    
    if (sumAgain<properties0) or (REAgain=10) then      //重来
    begin
      for j:=low(MyabcList) to high(MyabcList) do
      begin
        iAgain:=iAgain*properties3;
        MyabcList[j]:=abcList[j];
        //MyabcList[j].MinV:=max(abcList[j].MinV,abcMax[j]-(abcList[j].MaxV-abcList[j].MinV)/iAgain/2);
        //MyabcList[j].MaxV:=min(abcList[j].MaxV,abcMax[j]+(abcList[j].MaxV-abcList[j].MinV)/iAgain/2);
        MyabcList[j].Precision:=trunc(abcList[j].Precision*iAgain);          //属性
      end;
      MydMax:=MaxExtended;
    end
    else
    begin
      for j:=low(MyabcList) to high(MyabcList) do
      begin
        MyabcList[j].MinV:=max(MyabcList[j].MinV,MyabcMax[j]-(MyabcList[j].MaxV-MyabcList[j].MinV)/(properties1)/2);//属性   //局部爬山
        MyabcList[j].MaxV:=min(MyabcList[j].maxV,MyabcMax[j]+(MyabcList[j].MaxV-MyabcList[j].MinV)/(properties1)/2);
        if MyabcList[j].PType=2 then
        begin
          MyabcList[j].MinV:=trunc(MyabcList[j].MinV);
          MyabcList[j].MaxV:=trunc(MyabcList[j].MaxV);
        end;
        MyabcList[j].Precision:=trunc(max(2.0,MyabcList[j].Precision/properties2));//属性
      end;
    end;
    
  end;
end;


//==============================================================================

type TDNA_Order =record
  ID    :integer;
  Value :Extended;
end;

type PArrayTDNA_Order=array of TDNA_Order;

procedure OrderBY(var Order :array of TDNA_Order;var OrderTemp :array of TDNA_Order);
var
  i,j   :integer;
  L,R   :integer;
  LR2   :integer;
  InID  :integer;
begin
  OrderTemp[0]:=Order[0];
  for i:=1 to high(Order) do    //中值插入法排序
  begin
    L:=0;
    R:=i-1;
    while L<=R do
    begin
      LR2:=(R+L) div 2;
      if Order[i].Value<OrderTemp[LR2].Value then
        R:=LR2-1
      else
        L:=LR2+1;
    end;
    InID:=L;
    if InID<i then
    begin
      for j:=i-1 downto InID do
      begin
        OrderTemp[j+1]:=OrderTemp[j];
      end;
    end ;
    OrderTemp[InID]:=Order[i];
  end;

  for i:=0 to high(Order) do
  begin
    Order[i]:=OrderTemp[i];
  end;
end;

procedure GetK(var k1:integer;const Pr:array of Extended); overload;
var
  i     :integer;
  Psum  :Extended;
  r     :extended;
begin
  r:=random;
  Psum:=0;
  for i:=0 to high(Pr) do
  begin
     Psum:=Psum+Pr[i];
     if r<=Psum then
     begin
       K1:=i;
       exit;
     end;
  end;
  k1:=high(Pr);   //不可能到这里执行  因为Pr的和为1
end;

procedure GetK(var k1,k2:integer;const Pr:array of Extended); overload;
begin
  GetK(K1,Pr);
  GetK(K2,Pr);
  while K1=K2 do    //使K1<>K2
  begin
    GetK(K2,Pr);
  end;
end;

procedure RunOptimize4();   //基因算法
var
  MyTime      :extended;
  i,j,k1,k2,k0:integer;

  dTemp       :extended;
  Temp        :extended;
  MyabcList   :array of TabcList;

  Pr          :array of Extended;   //繁殖概率
  DNA         :array of array of Extended; //基因 种群
  DNA_Temp    :array of array of Extended; //临时交换的 基因 种群
  DNA_Order   :array of TDNA_Order; //基因适应值  排序用
  OrderTemp   :array of TDNA_Order; //临时 基因适应值  排序用
  t           :integer;              //当前繁殖代数
  DetaX       :extended;          //非一致变异步长

  properties0 :integer;
  properties1 :Extended;
  properties2 :Extended;
  properties3 :Extended;
  properties4 :Extended;
  properties5 :Extended;
  properties6 :Extended;
  properties7 :Extended;
  properties8 :Extended;
  properties9 :Extended;

begin
  //初始设定
  SetThreadPriority(GetCurrentThread(),THREAD_PRIORITY_LOWEST);
  randomize;
  setlength(MyabcList,high(abcList)+1);
  for i:=low(MyabcList) to high(MyabcList) do
    MyabcList[i]:=abcList[i]; 
  setlength(abcMax,high(abcList)+1);

  properties0:=trunc(GetKeyValue('基因算法.种群大小'));
  if properties0<1 then properties0:=2;
  properties0:=((properties0+1 )div 2)*2;  // 2的倍数

  properties1:=GetKeyValue('基因算法.繁殖选择压力(0-1)');
  properties1:=(properties1+1)/properties0;
  if properties1>1 then properties1:=1 else if properties1<0 then properties1:=0;

  properties2:=GetKeyValue('基因算法.最大代数');
  if properties2<1 then properties2:=1;

  properties3:=GetKeyValue('基因算法.局部微调系数');

  properties4:=abs(GetKeyValue('基因算法.一致变异强度(强度和为种群大小)'));
  properties5:=abs(GetKeyValue('基因算法.非一致变异强度(局部微调)'));
  properties6:=abs(GetKeyValue('基因算法.单点一致交叉强度'));
  properties7:=abs(GetKeyValue('基因算法.启发式交叉强度'));
  properties8:=abs(GetKeyValue('基因算法.一般算术交叉强度'));
  properties9:=abs(GetKeyValue('基因算法.完全算术交叉强度'));

  //强度 
  temp:=properties4+properties5+properties6+properties7+properties8+properties9;
  if temp=0 then
  begin
    properties4:=properties0 div 6;
    properties5:=properties4+(properties0 div 6);
    properties6:=properties5+(properties0 div 6);
    properties7:=properties6+(properties0 div 6);
    properties8:=properties7+(properties0 div 6);
    properties9:=properties0;
  end
  else
  begin
    properties4:=trunc(properties4*properties0/Temp );
    properties5:=properties4+trunc(properties5*properties0/Temp );
    properties6:=properties5+trunc(properties6*properties0/Temp );
    properties7:=properties6+trunc(properties7*properties0/Temp );
    properties8:=properties7+trunc(properties8*properties0/Temp );
    properties9:=properties0;
  end;
  properties9:=properties9-1;//留下一个名额给最优的基因


  //繁殖几率
  setlength(Pr,(properties0));
  Temp:=properties1/(properties0-1);
  for i:=0 to (properties0)-1 do
  begin
    Pr[i]:=properties1-i*Temp;    // pr[0..properties0-1]的和为1
  end;
  {Temp:=0;
  for i:=0 to (properties0)-1 do
  begin
    temp:=Temp+pr[i];
  end;}
  //

  setLength(DNA,properties0);
  setLength(DNA_Temp,properties0);
  for i:=0 to properties0-1 do
  begin
    setLength(DNA[i],high(MyAbcList)+1);
    setLength(DNA_Temp[i],high(MyAbcList)+1);
  end;
  setLength(DNA_Order,properties0);
  setLength(OrderTemp,properties0);
  
  //循环
  NowTime:=windows.GetTickCount();
  MyTime:=NowTime;
  while MyTime=NowTime do   //不按“停止”键就一直运行
  begin
    application.ProcessMessages;

    //产生初始基因
    for j:=0 to high(MyAbcList) do
    begin
      DNA[0,j]:=MyAbcList[j].Default;
    end;
    for i:=1 to properties0-1 do
    begin
      for j:=0 to high(MyAbcList) do
      begin
        DNA[i,j]:=random*(MyAbcList[j].MaxV-MyAbcList[j].MinV)+MyAbcList[j].MinV;
      end;
    end;
    //
    
    t:=0;
    while t<=properties2 do
    begin
      t:=t+1;

      //计算适应值
      for i:=0 to properties0-1 do
      begin
        for j:=0 to high(MyAbcList) do
        begin
          MyAbcList[j].Default:=DNA[i,j];
          if MyAbcList[j].PType=2 then
            MyAbcList[j].Default:=trunc(MyAbcList[j].Default);
        end;
        DNA_Order[i].Value:=abs(GetFBValue(MyabcList));
        DNA_Order[i].ID:=i;
      end;
      //按适应值大小排名
      OrderBY(DNA_Order,OrderTemp); //从小到大排序

      if DNA_Order[0].Value<dMax then   //最优值
      begin
        dMax:=DNA_Order[0].Value;
        for j:=low(abcMax) to high(abcMax) do
          abcMax[j]:=DNA[DNA_Order[0].ID,j];
        application.ProcessMessages;
      end;

      //产生后代
      for j:=0 to high(MyAbcList) do //保留最优秀的基因
      begin
        DNA_Temp[properties0-1,j]:=DNA[DNA_Order[0].ID,j];
      end;
      for i:=0 to trunc(properties4)-1 do //一致变异
      begin
        GetK(k1,pr);
        for j:=0 to high(DNA[0]) do
          DNA_Temp[i,j]:=DNA[DNA_Order[k1].ID,j];
        K0:=random(high(DNA[0])+1);
        DNA_Temp[i,K0]:=random*(MyabcList[K0].MaxV-MyabcList[k0].MinV)+MyabcList[k0].MinV;
      end;

      for i:=trunc(properties4) to trunc(properties5)-1 do //非一致变异(局部微调)
      begin
        GetK(k1,pr);
        for j:=0 to high(DNA[0]) do
          DNA_Temp[i,j]:=DNA[DNA_Order[k1].ID,j];
        K0:=random(high(DNA[0])+1);
        TEmp:=DNA_Temp[i,k0];
        if random<0.5 then
        begin
          DetaX:=(MyabcList[k0].MaxV-TEmp)*random*power(1-t/properties2,properties3);
          DNA_Temp[i,k0]:=min(MyabcList[k0].MaxV,TEmp+DetaX);
        end
        else
        begin
          DetaX:=(TEmp-MyabcList[k0].MinV)*random*power(1-t/properties2,properties3);
          DNA_Temp[i,k0]:=max(MyabcList[k0].MinV,TEmp-DetaX);
        end;
      end;

      for i:=trunc(properties5) to trunc(properties6)-1 do //单点一致交叉
      begin
        GetK(k1,k2,pr);
        K0:=random(high(DNA[0])+1);
        for j:=0 to k0 do
          DNA_Temp[i,j]:=DNA[DNA_Order[k1].ID,j];
        for j:=k0+1 to high(DNA[0]) do
          DNA_Temp[i,j]:=DNA[DNA_Order[k2].ID,j];
      end;

      for i:=trunc(properties6) to trunc(properties7)-1 do //启发式交叉
      begin
        GetK(k1,k2,pr);
        if DNA_Order[k1].Value<DNA_Order[k2].Value then
        begin
          for j:=0 to high(DNA[0]) do
          begin
            DNA_Temp[i,j]:=random*(DNA[DNA_Order[k1].ID,j]-DNA[DNA_Order[k2].ID,j])+DNA[DNA_Order[k1].ID,j];
            if DNA_Temp[i,j]>MyabcList[j].MaxV then DNA_Temp[i,j]:=MyabcList[j].MaxV;
            if DNA_Temp[i,j]<MyabcList[j].MinV then DNA_Temp[i,j]:=MyabcList[j].MinV;
          end;
        end
        else
        begin
          for j:=0 to high(DNA[0]) do
          begin
            DNA_Temp[i,j]:=random*(DNA[DNA_Order[k2].ID,j]-DNA[DNA_Order[k1].ID,j])+DNA[DNA_Order[k2].ID,j];
            if DNA_Temp[i,j]>MyabcList[j].MaxV then DNA_Temp[i,j]:=MyabcList[j].MaxV;
            if DNA_Temp[i,j]<MyabcList[j].MinV then DNA_Temp[i,j]:=MyabcList[j].MinV;
          end;
        end;
      end;   

      for i:=trunc(properties7) to trunc(properties8)-1 do //一般算术交叉
      begin
        GetK(k1,k2,pr);
        K0:=random(high(DNA[0])+1);
        Temp:=random;
        if random<0.5 then
        begin
          for j:=0 to k0 do
            DNA_Temp[i,j]:=DNA[DNA_Order[k1].ID,j];
          for j:=k0+1 to high(DNA[0]) do
          begin
            DNA_Temp[i,j]:=Temp*DNA[DNA_Order[k1].ID,j]+(1-Temp)*DNA[DNA_Order[k2].ID,j];
            if DNA_Temp[i,j]>MyabcList[j].MaxV then DNA_Temp[i,j]:=MyabcList[j].MaxV;
            if DNA_Temp[i,j]<MyabcList[j].MinV then DNA_Temp[i,j]:=MyabcList[j].MinV;
          end;
        end
        else
        begin
          for j:=0 to k0 do
          begin
            DNA_Temp[i,j]:=Temp*DNA[DNA_Order[k1].ID,j]+(1-Temp)*DNA[DNA_Order[k2].ID,j];
            if DNA_Temp[i,j]>MyabcList[j].MaxV then DNA_Temp[i,j]:=MyabcList[j].MaxV;
            if DNA_Temp[i,j]<MyabcList[j].MinV then DNA_Temp[i,j]:=MyabcList[j].MinV;
          end;
          for j:=k0+1 to high(DNA[0]) do
            DNA_Temp[i,j]:=DNA[DNA_Order[k1].ID,j];
        end;
      end;

   for i:=trunc(properties8) to trunc(properties9)-1 do //完全算术交叉
      begin
        GetK(k1,k2,pr);
        Temp:=random;
        for j:=0 to high(DNA[0]) do
        begin
          DNA_Temp[i,j]:=Temp*DNA[DNA_Order[k1].ID,j]+(1-Temp)*DNA[DNA_Order[k2].ID,j];
          if DNA_Temp[i,j]>MyabcList[j].MaxV then DNA_Temp[i,j]:=MyabcList[j].MaxV;
          if DNA_Temp[i,j]<MyabcList[j].MinV then DNA_Temp[i,j]:=MyabcList[j].MinV;
        end;
      end;

      
      //复制
      for i:=0 to properties0-1 do
      begin
        for j:=0 to high(DNA[0]) do
          DNA[i,j]:=DNA_Temp[i,j];
      end;

      //系统
      application.ProcessMessages;
      while runPause=true do
      begin
        application.ProcessMessages;
        sleep(1);
      end;
      application.ProcessMessages;
      if MyTime<>NowTime then exit;
      application.ProcessMessages;

    end;//while t<=properties2 do
  end;//while MyTime=NowTime do
end;


end.