jzq.dpr

井字棋的delphi源码

{
  井字棋:2008-2-24
  作者:njhhack
  E-mail:[e-mail]
  QQ:10772919
  本程序的特点是score估值函数的算法很优秀，一步即可得最优解
  如果要调试程序，则可以将/$apptype console/启用，则可以使用dos窗口
}
program jzq;
uses
  windows,messages,sysutils;
  {$R jzq.res}
  //{$apptype console}
type
 TWin = record
   Msg:TMsg;
   wClass:TWndClass;
   hMain:integer;
   lr:trect;
   tem:TEVENTMSG;
   hbrEmpty,hbrWhite,hbrBlack,hbrRed,hbrRed2,hbrGreen,hbrTemp,hOldBrush,hbrYellow:HBRUSH;
	 hpeBlack,hpeWhite,hOldpen:HPEN;
	 logbrush1:LOGBRUSH ;
   hmemdc,hbackdc,htmpdc:HDC;
	 srt,rt:TRECT;
   hbit1,hbit2,hbit3,hBitmap,hSrcBMP:HBITMAP ;
	 ps:TPAINTSTRUCT ;
 end;
var
  Win:TWin;                    //结构变量
  hdc:integer;
  pt:TPOINT;
  value,value1,x,y,wh:integer;
  szinfo:array[0..128] of char;//信息显示
  //下面是AI变量
  black:integer=1;
  white:integer=2;
  chess:array[1..9] of integer;//棋子表,1黑,2白,0空
  count,sc:integer;
  player,bestmove:integer;
  maxdepth:integer=1;
  line9:array[1..9] of integer=($1473,$152,$1683,$422,$25784,$262,$4383,$352,$3673);//构造每个点的组合,最后一位为数量
  line8:array[1..8] of integer=($123,$456,$789,$147,$258,$369,$159,$357);//组合线
//
//下面是估值函数
function score(depth:integer;player:integer;pos:integer):integer;
var
  x,d,k,s,r,y:integer;
  num:array[0..2] of integer;
begin
  inc(sc);
  result:=0;
  if pos=0 then exit;
  player:=2-((count+1) mod 2);//玩家
  s:=line9[pos] and $f;//根据坐标获取组合数
  for k:=1 to s do//s种组合
  begin
    for d:=0 to 2 do num[d]:=0;//清0
    r:=(line9[pos] shr (4*k)) and $f;//取得组合线编号
    for d:=1 to 3 do//每线3个子
    begin
      x:=(line8[r] shr (4*(3-d))) and $f;//坐标
      if chess[x]=0 then y:=0//无棋子
      else y:=2-(chess[x] mod 2);//y=player
      inc(num[y]);
    end;
    d:=(num[player] shl 4) or num[0];//给合结果
    case d of
      $12:result:=result+1;//1分,100
      $11:result:=result+10;//10分,120
      $21:result:=result+100;//100分,110
      $20:result:=result+1000;//1000分,112
      $10:result:=result+10000;//10000分,122
      $30:result:=result+100000;//100000分,111
    end;
    //writeln('d=',inttohex(d,2),' result= ',result,'   ');
  end;
  //for d:= 1 to 9 do write(chess[d]);  writeln('  s= ',s,', player= ',player,', count= ',count,' pos= ',pos,', depth= ',depth,',result= ',result);
end;
//负极大值搜索函数,深度为1
function NegaMax(depth:integer;player:integer;pos:integer):integer;
var
  k,value:integer;
begin
  //if depth=0 then writeln;
  result:=-100000;//取一个很大的负值
  value:=-score(depth,player,pos);
  if (depth>=maxdepth) or (count>=9) or (value>=100000) or (value<=-100000) then//count>=9时棋已下满
  begin
    result:=value;//自已
    exit;
  end;
  for k:=1 to 9 do
  begin
    if chess[k]<>0 then continue;//有子继续
    inc(count);//增加一步
    chess[k]:=count-1;//下子
    value:=-NegaMax(depth+1,(player mod 2)+1,k);
    if value>result then
    begin
      result:=value;
      bestmove:=k;//记下位置
    end;
    chess[k]:=0;//提子
    dec(count);//退回一步
  end;
end;
//下面是windows界面函数
procedure wmlbuttondown;
var k:integer;
begin
	GetCursorPos(pt);
	ScreenToClient(win.hmain,pt);
  wh:=28;
	x:=(pt.x-14*2) div wh;
	y:=(pt.y-2-14*2) div wh;
	if ((x<0) or (x>2) or (y>2) or (y<0)) then exit;
  if chess[y*3+x+1]<>0 then exit;
  //有效棋子
  chess[y*3+x+1]:=count;
  player:=(player mod 2)+1;
  inc(count);
  value1:=score(0,player,y*3+x+1);
  if (value1>=100000) or (count>9) then
  begin
    if value1>=100000 then messageboxa(0,pchar('你胜了'),pchar(''),0)
    else messageboxa(0,pchar('和棋'),pchar(''),0);
    count:=1;
    player:=1;
    for k:=1 to 9 do chess[k]:=0;
    exit;
  end;
  //writeln(value,',',y*3+x+1,',',player);
  if (count<=9) then
  begin
    //下面电脑算
    sc:=0;
    value:=NegaMax(0,player,0);
    chess[bestmove]:=count;
    inc(count);
    player:=(player mod 2)+1;
    if (value>=100000) or (count>9) then
    begin
      if value>=100000 then messageboxa(0,pchar('电脑胜了'),pchar(''),0)
      else messageboxa(0,pchar('和棋'),pchar(''),0);
      count:=1;
      player:=1;
      for k:=1 to 9 do chess[k]:=0;
      exit;
    end;
  end;
  //
  //DrawBoard;
end;
//
procedure DrawString;
var k:integer;
begin
  strcopy(szinfo,pchar(format('鼠标=(%d,%d)',[x+1,y+1])));
  strcat(szinfo,pchar(#13#10));
  strcat(szinfo,pchar(format('步数=%d',[count-1])));
  strcat(szinfo,pchar(#13#10));
  strcat(szinfo,pchar(format('你的分数=%d',[value1])));
  strcat(szinfo,pchar(#13#10));
  strcat(szinfo,pchar(format('电脑分数=%d',[value])));
  strcat(szinfo,pchar(#13#10));
  strcat(szinfo,pchar(format('搜索节点=%d',[sc])));
  //strcat(szinfo,pchar(#13#10));
  //for k:=1 to 9 do strcat(szinfo,pchar(format('%d',[chess[k]])));
  with win.rt do
  begin
    left:=128;
    top:=22;
    right:=left+100;
    bottom:=top+80;
  end;
	FillRect(win.hmemdc,win.rt,win.hbrTemp);//清屏
  SetTextColor(win.hmemdc,RGB(0,0,0));
  DrawText(win.hmemdc,szinfo, strlen(szinfo),win.rt,DT_LEFT);
end;
//
procedure DrawBoard;
var
	k1,k,x,y,w1,w2:integer;
  str0:array[0..12] of char;
begin
	//填充背景
  GetClientRect(win.hmain,win.srt);
  SelectObject(win.hmemdc,win.hbrTemp);
	FillRect(win.hmemdc,win.srt,win.hbrTemp);
  //
  w1:=28;
  w2:=w1 div 2;
  //
  SelectObject(win.hmemdc,win.hpeBlack);
  SelectObject(win.hmemdc,win.hbrEmpty);
  //画棋盘
  for k:=0 to 8 do
  begin
    x:=k mod 3;
    y:=k div 3;
    rectangle(win.hmemdc,x*w1+w1-1,y*w1+w1-1,x*w1+w1*2,y*w1+w1*2);
  end;
  //画棋子
  for k:=0 to 8 do
  begin
    x:=k mod 3;
    y:=k div 3;
    if chess[k+1]<>0 then
    begin
      k1:=chess[k+1] mod 2;
      if k1=0 then  //画黑棋
      begin
        SelectObject(win.htmpdc,win.hbit1);
        TransparentBlt(win.hmemdc,x*w1+w1,y*w1+w1,28,28,win.htmpdc,0,0,27,27,rgb($ff,$ff,$ff));
        SelectObject(win.hmemdc,win.hpeBlack);
        SelectObject(win.hmemdc,win.hbrWhite);
   			SetTextColor(win.hmemdc,RGB(0,0,0));
  			//SetBkColor(win.hmemdc,RGB(255,225,255));
      end else      //画白棋
      begin
        SelectObject(win.htmpdc,win.hbit2);
        TransparentBlt(win.hmemdc,x*w1+w1,y*w1+w1,28,28,win.htmpdc,0,0,27,27,rgb($ff,$ff,$ff));
        SelectObject(win.hmemdc,win.hpeWhite);
        SelectObject(win.hmemdc,win.hbrBlack);
   			SetTextColor(win.hmemdc,RGB(255,255,255));
  			//SetBkColor(win.hmemdc,RGB(0,0,0));
      end;
      //Ellipse(win.hmemdc,x*w1+w1-1,y*w1+w1,x*w1+2*w1-1,y*w1+2*w1);
    end;
    k1:=chess[k+1]-1;
    //生成文字
    str0[0]:=char($30+k1+1);
    str0[1]:=#0;
    SetBkMode(win.hmemdc,TRANSPARENT);
    //生成文字坐标
    with win.rt do
    begin
      left:=x*w1+8*3-1+14;
      top:=y*w1+6+w2+14;
      right:=left+8*6;
      bottom:=top+20;
    end;
    //在棋子上显示文字
    if chess[k+1]<>0 then DrawText(win.hmemdc,@str0,strlen(str0),win.rt,DT_LEFT);
  end;
  //
  SelectObject(win.hmemdc,win.hbrTemp);//恢复笔刷
  DrawString;
  InvalidateRect(win.hmain,@win.srt,true);
end;

procedure wmcreate(hwnd:thandle);
begin
  player:=1;
  count:=1;
  win.logbrush1.lbStyle:=BS_NULL;
	win.hbrTemp:=CreateSolidBrush(RGB($e0,$f0,$e0));
	win.hbrBlack:=CreateSolidBrush(RGB($0,$0,$0));
	win.hbrWhite:=CreateSolidBrush(RGB($ff,$ff,$ff));
  win.hpeBlack:=CreatePen(0,0,RGB(0,0,0));
  win.hpeWhite:=CreatePen(0,0,RGB(255,255,255));
	win.hbrEmpty:=CreateBrushIndirect(win.logbrush1);
  win.hbit1:=LoadBitmap(hInstance,'pc1');
  win.hbit2:=LoadBitmap(hInstance,'pc2');
  win.hbit3:=LoadBitmap(hInstance,'pc3');
	GetClientRect(hwnd,win.srt);
	hdc:=GetDC(hwnd);
	if win.hmemdc<>0 then DeleteDC(win.hmemdc);
	win.hmemdc:=CreateCompatibleDC(hdc);
	if win.htmpdc<>0 then DeleteDC(win.htmpdc);
	win.htmpdc:=CreateCompatibleDC(hdc);
	if win.hBitmap<>0 then DeleteObject(win.hBitmap);
	win.hBitmap:=CreateCompatibleBitmap (hdc, win.srt.right, win.srt.bottom);
	SelectObject(win.hmemdc, win.hBitmap);
  SelectObject(win.hmemdc,win.hbrTemp);//恢复笔刷
	ReleaseDC(hwnd,hdc);
	SetTimer(hwnd,11,100,nil);
end;

procedure WmSize;
begin
	GetClientRect(win.hmain,win.srt);
	hdc:=GetDC(win.hmain);
	if win.hmemdc<>0 then DeleteDC(win.hmemdc);
	win.hmemdc:=CreateCompatibleDC(hdc);
	if win.htmpdc<>0 then DeleteDC(win.htmpdc);
	win.htmpdc:=CreateCompatibleDC(hdc);
	if win.hBitmap<>0 then DeleteObject(win.hBitmap);
	win.hBitmap:=CreateCompatibleBitmap (hdc, win.srt.right, win.srt.bottom);
	SelectObject(win.hmemdc, win.hBitmap);
	ReleaseDC(win.hmain,hdc);
  DrawBoard;
end;


procedure wmrbuttondown;
var x:integer;
begin
  if count<=1 then exit;
  dec(count);
	GetCursorPos(pt);
	ScreenToClient(win.hmain,pt);
  for x:=0 to 8 do
  begin
    if chess[x+1]=count then
    begin
      chess[x+1]:=0;
      exit;
    end;
  end;
  //有效棋子
  player:=(player mod 2)+1;
  DrawBoard;
end;

procedure wmclose;
begin
end;

procedure wmmousemove;
begin
	GetCursorPos(pt);
	ScreenToClient(win.hmain,pt);
	x:=(pt.x-14*2) div wh;
	y:=(pt.y-2-14*2) div wh;
end;
//将信息写到屏幕
procedure wmpaint;
begin
 hdc:=BeginPaint(win.hmain,win.ps);
 BitBlt(hdc,0,0,win.srt.right,win.srt.bottom,win.hmemdc,0,0,SRCCOPY);
 EndPaint(win.hmain,win.ps);
end;
//主程序的回调函数
function WindowProc(hWnd,Msg,wParam,lParam:longint):LRESULT; stdcall;
begin
  result:=0;
 case Msg of
 WM_ERASEBKGND:exit;//在该消息中不要调用默函数，则背景不会闪烁
 wm_create:wmcreate(hwnd);
 wm_timer:drawboard;
 wm_paint:wmpaint;
 wm_size:wmsize;
 wm_close:wmclose;
 WM_LBUTTONDOWN:wmlbuttondown;
 WM_RBUTTONDOWN:wmrbuttondown;
 WM_mousemove:wmmousemove;
 wm_char:if wparam=VK_ESCAPE then destroywindow(hwnd);//按ESC 键退出系统
 wm_destroy:halt;
 end;
 Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
end;
//主程序的执行函数
procedure run;stdcall;
begin
 wh:=28;
 win.wClass.hInstance:=    hInstance;
 with win.wclass do
 begin
   hIcon:=        LoadIcon(hInstance,'pp2');
   hCursor:=      LoadCursor(0,IDC_ARROW);
   hbrBackground:= COLOR_BTNFACE+1;
   Style:=        CS_PARENTDC;
   lpfnWndProc:=  @WindowProc;
   lpszClassName:='renju2008';
 end;
 RegisterClass(win.wClass);
 win.hmain:=CreateWindow(win.wClass.lpszClassName,'井字棋 ([e-mail])',WS_VISIBLE or WS_OVERLAPPEDWINDOW,10,10,270,170,0,0,hInstance,nil);
 while(GetMessage(win.Msg,win.hmain,0,0))do
 begin
   TranslateMessage(win.Msg);
   DispatchMessage(win.Msg);
 end;
end;

begin
  run;
end.