如何利用遗传算法设计博弈AI

unit genetic;

interface
uses System.SysUtils, System.Variants, System.Classes,generics.collections,math;

type
 TChromosome=record              //染色体
 gen:array [0..2] of word ;      //基因
 va:single;                      //表现型
 end;

procedure heaps(list:Tlist<single>);  //内置一个堆排序
function  heapadjust(list:Tlist<single>;s,m:integer):boolean; //堆排序筛选

type
 TGenetic=class
   private
   par:Tlist<TChromosome>;       //父代
   char:Tlist<TChromosome>;      //子代
   geneamount:integer;           //基因规模(长度)
   stablecount:integer;
   procedure value(var sample:TChromosome);              //适应函数
   function  select(pro:array of single):integer;    //选择函数（轮盘赌）
   procedure exc(var p1,p2:TChromosome);                 //染色体交叉，变异
   procedure c_original();
   procedure c_Posterity();
   public
   G_varitionrate:single;    //变异概率
   G_crossrate:single;       //交叉概率
   G_oriamount:integer;      //原始父代数目
   G_popmax:integer;         //种群最大数量
   G_selectpar:integer;      //子代选择数目
   G_genecount:integer;      //种群进化代数
   G_maxevolu:integer;       //最大进化代数
   G_gebest:Tlist<Tchromosome>;   //每代最优解
   G_stablecount:integer;    //稳定遗传
   procedure  G_Evolution(); //进化过程
   constructor create;
 end;


implementation

constructor Tgenetic.create;
begin
  par:=Tlist<Tchromosome>.create;
  char:=Tlist<Tchromosome>.create;
  G_gebest:=Tlist<Tchromosome>.create;
  G_oriamount:=1000;
  G_popmax:=2000;
  G_selectpar:=200;
  G_genecount:=0;
  G_maxevolu:=50;
  geneamount:=10000;
  G_varitionrate:=0.01;
  G_crossrate:=1;
  G_stablecount:=10;  //n代不变则认为稳定
end;

procedure Tgenetic.G_Evolution;
begin
  G_genecount:=0;
  c_original;
  while True do
  begin
   c_Posterity;
   inc(G_genecount);
   G_gebest.Add(par.Items[0]);
    if G_genecount>=G_stablecount then
    if (G_gebest.Items[G_genecount-1].va=G_gebest.Items[G_genecount-G_stablecount].va) then break;
    if G_genecount>=G_maxevolu then  break;
end;
end;


procedure Tgenetic.value(var sample:TChromosome);
var
x,y,z:integer;
begin
  x:=sample.gen[0];
  y:=sample.gen[1];
  z:=sample.gen[2];
  sample.va:=sin(x)+power(1+cos(y+z),2+sin(ln(1+abs(tan(y+z))))/(x+y+1));
  //sample.va:=7*x+ln(y+1)+z;
end;

procedure Tgenetic.c_original;
var
i,J:integer;
s:Tchromosome;
begin
 for I := 1 to G_oriamount do
  begin
  for j := 0 to 2 do
  s.gen[j]:=random(geneamount);
  value(s);
  par.Add(s);
  end;
end;

procedure Tgenetic.c_Posterity;
var
i:integer;
sum:double;
prob:array of single;
index:integer;
p1,p2:Tchromosome;
listpx:Tlist<Tchromosome>;
listv,listv0:Tlist<single>;
begin
  listv:=Tlist<single>.create;
  listv0:=Tlist<single>.create;
  listpx:=Tlist<Tchromosome>.create;
  sum:=0;
  setlength(prob,par.count);  //概率
  for I := 0 to par.count-1 do
    sum:=sum+par.items[i].va;
  for I := 0 to par.count-1 do
    prob[i]:=par.items[i].va/sum;
  index:=1;
  while index<=(G_popmax div 2) do
  begin
   p1:=par.Items[select(prob)];
   p2:=par.Items[select(prob)];
   exc(p1,p2);
   value(p1);
   value(p2);
   char.Add(p1);
   char.Add(p2);
   inc(index);
  end;
  par.Clear;
  for I := 0 to char.Count-1 do
   listpx.Add(char.Items[i]);
  char.Clear;
  for I := 0 to listpx.Count-1 do
  begin
   listv.Add(listpx.Items[i].va);
   listv0.Add(listpx.Items[i].va);
  end;
  heaps(listv);          //堆排序
  for I := listpx.Count-G_selectpar to listpx.Count-1 do
   par.Add(listpx.Items[listv0.IndexOf(listv.Items[i])]);
end;

function Tgenetic.select(pro: array of single):integer;
var
i:integer;
num:double;
sum:double;
areap:array of single;                //轮盘
low,high,mid:integer;
begin
  setlength(areap,length(pro));
  i:=0;
  sum:=0;
  for I := 0 to length(pro)-1 do
  begin
   areap[i]:=sum+pro[i];
   sum:=areap[i];
  end;
  num:=randomrange(1,9999999)/10000000;    //轮盘赌算法
  if (num>=0) and (num<=areap[0]) then
  begin
   result:=0;
   exit;
  end;
  if (num>=areap[length(areap)-1]) and (num<=1) then
  begin
   result:=length(areap)-1;
   exit;
  end;
  low:=1;
  high:=length(areap);
 while(low<=high) do             //折半查找
 begin
  mid:=trunc((low+high)/2);
  if (num>=areap[mid-1]) and (num<=areap[mid]) then
  break;
  if num>=areap[mid-1] then low:=mid
  else high:=mid;
 end;
result:=mid;
end;

procedure Tgenetic.exc(var p1,p2: Tchromosome);
var
exn:integer;
i:integer;
temp:integer;
excr:single;
vari:single;
begin
  exn:=random(3);      //3元
  if G_crossrate>random(1000)/1000 then
   for I := exn to 2 do         //交叉
    begin
    temp:=p1.gen[i];
    p1.gen[i]:=p2.gen[i];
    p2.gen[i]:=temp;
    end;
  excr:=random(10000)/10000;
  if excr<G_varitionrate then    //变异
  begin
   i:=random(3);
   p1.gen[i]:=random(geneamount);
  end;
  if excr<G_varitionrate then    //变异
  begin
   i:=random(3);
   p2.gen[i]:=random(geneamount);
  end;
  p1.va:=0;
  p2.va:=0;
end;





procedure heaps(list:Tlist<single>);
var
i:integer;
temp:real;
begin
i:=list.Count div 2;
while i>0 do                             //建成大顶堆
  begin
  heapadjust(list,i,list.Count-1);
  dec(i);
  end;
i:=list.Count;
while i>1 do
  begin
  temp:=list.Items[0];
  list.Items[0]:=list.Items[i-1];
  list.Items[i-1]:=temp;
  heapadjust(list,1,i-1);
  dec(i);
  end;
end;

function heapadjust(list: TList<System.single>; s: Integer; m: Integer):boolean;
var j:integer;
    temp:real;
begin
temp:=list.Items[s-1];
j:=2*s;
while (j<=m) do
  begin
  if (j<m)and(list.Items[j-1]<list.Items[j]) then
  inc(j);
  if temp>=list.Items[j-1] then
  break;
  list.Items[s-1]:=list.Items[j-1];
  s:=j;
  j:=2*j;
  end;
  list.Items[s-1]:=temp;
end;


end.