Refresh on the IE widget break down the app >>
<< 705行的五子棋代码
{705行的五子…

Author Zhou Renjian Create@ 2004-07-24 06:48 Modified@ 2004-07-24 06:49
whizz Note icon

{705行的五子棋高效pascal代码!
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!                           Notice                                               !
!  Software edited by Zhou Renjian,Shanghai Jiao Tong University,Mathethics!
!Application Apartment F0007102.                                           !
!                               (C)Copyright Stand Man Studio (to be built)!
!  本软件有上海交通大学数学系F0007102班周仁建编写,在Turbo Pascal 7.0 下通 !
!过。可以写信给我共同讨论。                                                !
!                               Email:bombjet.joo@263.net                  !
!                                                                          !
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
}
uses Graph,Crt;
const
  ChessW=19;{棋盘宽}
  BlankW=24;{棋盘高}
  _Color1=BROWN;
  _Color2=WHITE;
  Delta:array [1..4,0..1] of Integer=((1,0),(0,1),(1,1),(1,-1));
 {Directories for the Chess.}
  VV:array [0..4] of Word=(0,8,64,512,4096);
 {The value for the Chess,as 0:_ _ _ _ _;8:_ O _ _ _;4096:O O O O _.}
type
  ValueDot=record
      V:Word;
      VN,D,LD,RD:Byte;
      LB,RB:Boolean;
    end;
  ValueD=record
    X,Y,D,LD,RD:Byte;
    LB,RB:Boolean;
    VN,V:Word;
  end;
var
  V0:ValueDot;
  Value:array [1..2,1..ChessW,1..ChessW,0..4] of ValueDot;
 {To record the chesses'values if it's empty;}
        {记录各个棋子的信息,1..2代表玩家代码,1..4代表四个方位,0代表总起来的。}
  ValueC:array [1..2,0..ChessW*ChessW,1..4] of ValueD;
        {记录有几粒的棋子条的信息,1..2代表玩家代码,1..4代表几粒。}
  BeginX,BeginY,CurrentX,CurrentY:Word;
 {For the screen.}
  Order:array[0..ChessW+1,0..ChessW+1] of Byte;
        {原本打算用作记录走棋的顺序,以便研究的,本程序没有用。}
  JustBegin:Boolean;

procedure InitChess;{Draw the forms and make some necessary init,such as give the 0 the chesses.}
  var
    grDriver: Integer;
    grMode: Integer;
    ErrCode: Integer;
    HalfX,HalfY,H:Word;
    ex,ey,i,j:Word;
  begin
    DirectVideo:=False;
    Randomize;
    JustBegin:=True;
    V0.VN:=0;V0.V:=0;V0.D:=25;V0.LD:=5;V0.RD:=5;V0.LB:=False;V0.RB:=False;
    for i:=1 to ChessW do
      for j:=1 to ChessW do  {初始化棋盘上的各个价值}
 begin
   Order[i,j]:=0;
   Value[1,i,j,0]:=V0;
   Value[1,i,j,1]:=V0;
   Value[1,i,j,2]:=V0;
   Value[1,i,j,3]:=V0;
   Value[1,i,j,4]:=V0;
   Value[2,i,j,0]:=V0;
   Value[2,i,j,1]:=V0;
   Value[2,i,j,2]:=V0;
   Value[2,i,j,3]:=V0;
   Value[2,i,j,4]:=V0;
 end;
    for i:=0 to ChessW+1 do
      begin
 Order[i,0]:=$ff;
 Order[0,i]:=$ff;
 Order[i,ChessW+1]:=$ff;
 Order[ChessW+1,0]:=$ff;
      end;

    CurrentX:=ChessW div 2;CurrentY:=ChessW div 2;
    grDriver := Detect;
    InitGraph(grDriver, grMode,'C:\TP\BGI');              {画棋盘}
    ErrCode := GraphResult;
    if ErrCode = grOk then
      begin  { Do graphics }
 BeginX:=GetMaxX div 2-(ChessW*BlankW div 2);
 BeginY:=GetMaxY div 2-(ChessW*BlankW div 2);
 ex:=GetMaxX div 2+(ChessW*BlankW div 2);
 ey:=GetMaxY div 2+(ChessW*BlankW div 2);
 SetFillStyle(1,BLUE);
 Bar(BeginX,BeginY,ex,ey);
 SetColor(YELLOW);
 for i:=1 to ChessW+1 do
   begin
     Line(BeginX+(i-1)*BlankW,BeginY,BeginX+(i-1)*BlankW,ey);
     Line(BeginX,BeginY+(i-1)*BlankW,ex,BeginY+(i-1)*BlankW);
   end;
      end
    else
      Halt;
  end;
procedure PutRect(_x,_y:Word;Erase:Boolean);{走棋时的方框}
  var
    r:Word;
  begin
    r:=BlankW -2;
    if Erase then SetColor(BLUE) else SetColor(RED);
    Rectangle(BeginX+_x*BlankW-r,BeginY+_y*BlankW-r,BeginX+_x*BlankW-1,BeginY+_y*BlankW-1);
    Rectangle(BeginX+_x*BlankW-r-1,BeginY+_y*BlankW-r-1,BeginX+_x*BlankW-2,BeginY+_y*BlankW-2);
  end;
procedure TPut(x,y,p:Byte);forward;
procedure PutChess(_x,_y:Word;player:Byte);
  var
    r:Word;
    color:Byte;
  begin
    r:=(BlankW div 2);
    if (_x>ChessW)or(_y>ChessW)or(Order[_x,_y]<>0) then exit;
    if player=1 then color:=_Color1 else
      if player=2 then color:=_Color2 else exit;
    SetColor(color);
    Circle(BeginX+_x*BlankW-r,BeginY+_y*BlankW-r,r-3);
    SetFillStyle(1,color);
    FloodFill(BeginX+_x*BlankW-r,BeginY+_y*BlankW-r,color);
    PutRect(CurrentX,CurrentY,True);{画棋子}
    Order[_x,_y]:=player;
    CurrentX:=_x;CurrentY:=_y;      {把此处的价值设置好}
    Value[1,_x,_y,0]:=V0;
    Value[2,_x,_y,0]:=V0;
    Value[1,_x,_y,1]:=V0;
    Value[2,_x,_y,1]:=V0;
    Value[1,_x,_y,2]:=V0;
    Value[2,_x,_y,2]:=V0;
    Value[1,_x,_y,3]:=V0;
    Value[2,_x,_y,3]:=V0;
    Value[1,_x,_y,4]:=V0;
    Value[2,_x,_y,4]:=V0;
    PutRect(CurrentX,CurrentY,False);
  end;
procedure ManTake(player:Byte);{Use the keyboard the take the chess.}
  var
    ch:Char;
    Take:Boolean;
  begin
    Take:=False;
    repeat
      ch:=#0;
      if KeyPressed then ch:=ReadKey;
      case ch of
 #71:{UpLeft}
     begin
       PutRect(CurrentX,CurrentY,True);
       if CurrentX>1 then CurrentX:=CurrentX-1;
       if CurrentY>1 then CurrentY:=CurrentY-1;
       PutRect(CurrentX,CurrentY,False);
     end;
 #72:{Up}
            begin
              PutRect(CurrentX,CurrentY,True);
       if CurrentY>1 then CurrentY:=CurrentY-1;
              PutRect(CurrentX,CurrentY,False);
            end;
        #73:{UpRight}
            begin
              PutRect(CurrentX,CurrentY,True);
              if CurrentX<ChessW then CurrentX:=CurrentX+1;
              if CurrentY>1 then CurrentY:=CurrentY-1;
              PutRect(CurrentX,CurrentY,False);
            end;
        #75:{Left}
            begin
              PutRect(CurrentX,CurrentY,True);
              if CurrentX>1 then CurrentX:=CurrentX-1;
              PutRect(CurrentX,CurrentY,False);
            end;
        #77:{Right}
            begin
              PutRect(CurrentX,CurrentY,True);
              if CurrentX<ChessW then CurrentX:=CurrentX+1;
       PutRect(CurrentX,CurrentY,False);
            end;
        #79:{DownLeft}
            begin
              PutRect(CurrentX,CurrentY,True);
              if CurrentX>1 then CurrentX:=CurrentX-1;
              if CurrentY<ChessW then CurrentY:=CurrentY+1;
              PutRect(CurrentX,CurrentY,False);
            end;
        #80:{Down}
            begin
              PutRect(CurrentX,CurrentY,True);
              if CurrentY<ChessW then CurrentY:=CurrentY+1;
              PutRect(CurrentX,CurrentY,False);
            end;
        #81:{DownRight}
            begin
              PutRect(CurrentX,CurrentY,True);
              if CurrentX<ChessW then CurrentX:=CurrentX+1;
              if CurrentY<ChessW then CurrentY:=CurrentY+1;
       PutRect(CurrentX,CurrentY,False);
     end;
 #13:{For sure}
     begin
       if Order[CurrentX,CurrentY]=0 then
  begin
    TPut(CurrentX,CurrentY,player);
    PutRect(CurrentX,CurrentY,False);
    Take:=True;
  end;
     end;
 else;
      end;
    until Take;
  end;
function CheckWin(player:Byte):Boolean;
  function CheckLine(bx,by:Word;dx,dy:Integer):Byte;
  {Check if there is 5 chesses in directions of -- | \ /.}
    var
      sum,maxsum:Byte;
    begin
      maxsum:=0;sum:=0;
      repeat
 if Order[bx,by]=player then
   begin
     sum:=sum+1;
     if sum>maxsum then maxsum:=sum;
   end
 else
   sum:=0;
 bx:=bx+dx;by:=by+dy;
      until (bx<1)or(bx>ChessW)or(by<1)or(by>ChessW);
      CheckLine:=maxsum;
    end;
  var
    i:Byte;
  begin
    CheckWin:=False;
    for i:=1 to ChessW do
      if CheckLine(1,i,1,0)>4 then
 begin                       {--}
   CheckWin:=True;Exit;
 end;
    for i:=1 to ChessW do
      if CheckLine(i,1,0,1)>4 then
 begin                       {|}
   CheckWin:=True;Exit;
 end;
    for i:=1 to ChessW-4 do
      if CheckLine(1,i,1,1)>4 then
 begin                        {\}
   CheckWin:=True;Exit;
 end;
    for i:=1 to ChessW-4 do
      if CheckLine(i,1,1,1)>4 then
 begin                         {\}
   CheckWin:=True;Exit;
 end;
    for i:=5 to ChessW do
      if CheckLine(i,1,-1,1)>4 then
 begin                           {/}
   CheckWin:=True;Exit;
 end;
    for i:=1 to ChessW-4 do
      if CheckLine(ChessW,i,-1,1)>4 then
 begin                            {/}
   CheckWin:=True;Exit;
 end;
  end;
procedure NetTake(player:Byte);
{This is for two players in two computers.It is based on the NETWARE 4.12,
not for the normal 2 computers.You can ignore this.}
{下面两个过程是为了使两台PC通过NETWARE4.12联起来玩游戏而作,可忽略。}
  var
    f:Text;
    tx,ty:Word;
  begin
    Assign(f,'SMS.NET');
    repeat
      {$I-}
      Reset(f);
      {$I+}
    until IOResult=0;
    Readln(f,tx);Readln(f,ty);
    Close(f);
    TPut(tx,ty,player);
  end;
procedure MyNetTake(player:Byte);
  var
    f:Text;
    tx,ty:Word;
  begin
    Assign(f,'SMS.NET');
    Rewrite(f);
    ManTake(player);
    Writeln(f,CurrentX);Writeln(f,CurrentY);
    Close(f);
  end;
procedure VD(x0,y0,d,p:Byte);{Caculate the value of the spot of (x0,y0).}
  var
    dx,dy:Integer;
    x,y,x1,y1,x2,y2,
    i,j,
    s0,s1,s2,ls,rs,s,_p,
    r0,l0,rd,ld,d0:Byte;
    lb,rb,rb0,lb0:Boolean;ll,rr:Byte;
    t,t0:Word;
    out,bb:Boolean;
    d1,d2:ValueDot;
  begin
    if Order[x0,y0]<>0 then Exit;
    dx:=Delta[d,0];dy:=Delta[d,1];{方向:--,|,/,\}
    if p=1 then _p:=2 else _p:=1;

    t0:=0;s0:=0;
    x:=x0;y:=y0;s1:=0;out:=false;
    repeat
      x:=x+dx;y:=y+dy;
      Inc(s1);                        {左有空白?}
      if (s1>4)or(Order[x,y]=$ff)or(Order[x,y]=_p) then out:=True;
    until out;
    if (Order[x,y]=$ff)or(Order[x,y]=_p) then Dec(s1);

    x:=x0;y:=y0;s2:=0;out:=false;
    repeat
      x:=x-dx;y:=y-dy;
      Inc(s2);                        {右有空白?}
      if (s2>4)or(Order[x,y]=$ff)or(Order[x,y]=_p) then out:=True;
    until out;
    if (Order[x,y]=$ff)or(Order[x,y]=_p) then Dec(s2);

    if s1+s2<4 then
      Value[p,x0,y0,d]:=V0
    else
      begin
 for i:=0 to s1 do
   if (4-i>=0)and(4-i<=s2) then
     begin
       ld:=1;rd:=1;rs:=0;ls:=0;

       x:=x0;y:=y0;ll:=0;bb:=True;lb:=False;
              for j:=1 to i do
                begin
                  x:=x+dx;y:=y+dy;       {中间有空白?数目几何?}
                  if Order[x,y]=p then Inc(ls);
                  if (ls=0)and(Order[x,y]=0) then Inc(ld);
                  if (bb)and(ls>0)and(Order[x,y]=0) then begin lb:=True;ll:=ls;bb:=False;end;
                end;
              if ls=ll then lb:=False;
              if ls=0 then ld:=5;
              x1:=x+dx;y1:=y+dy;

              x:=x0;y:=y0;rr:=0;bb:=True;rb:=False;
              for j:=1 to 4-i do
                begin
                  x:=x-dx;y:=y-dy;
                  if Order[x,y]=p then Inc(rs);
                  if (rs=0)and(Order[x,y]=0) then Inc(rd);
    if (bb)and(rs>0)and(Order[x,y]=0) then begin rb:=True;rr:=rs;bb:=False;end;
                end;
              if rs=0 then rd:=5;
              if rs=rr then rb:=False;
              x2:=x-dx;y2:=y-dy;

              s:=ls+rs;
              t:=VV[s];
              if (Order[x1,y1]=$ff)or(Order[x1,y1]=_p) then t:=t div 2;
              if (Order[x2,y2]=$ff)or(Order[x2,y2]=_p) then t:=t div 2;
              if t0<t then
                begin
                  t0:=t;s0:=s;r0:=rd;l0:=ld;rb0:=rb;lb0:=lb;
                end;
            end;
        Value[p,x0,y0,d].V:=t0;{此处d方向上价值}
        Value[p,x0,y0,d].VN:=s0;{此处d方向上棋子数}
        Value[p,x0,y0,d].LD:=l0;{此处d方向左空为几?}
        Value[p,x0,y0,d].RD:=r0;{此处d方向右空为几?}
        Value[p,x0,y0,d].LB:=lb0;{此处d方向左空?}
        Value[p,x0,y0,d].RB:=rb0;{此处d方向右空?}
        Value[p,x0,y0,d].D:=l0*r0;
      end;
    Value[p,x0,y0,0].V:=Value[p,x0,y0,1].V+Value[p,x0,y0,2].V+Value[p,x0,y0,3].V
+Value[p,x0,y0,4].V;
{四个方位的价值加起来,有选择地更新此处的价值,如果新的价值比原来的高。}
    if Value[p,x0,y0,1].V>Value[p,x0,y0,2].V then d1:=Value[p,x0,y0,1] else d1:=
Value[p,x0,y0,2];
    if Value[p,x0,y0,3].V>Value[p,x0,y0,4].V then d2:=Value[p,x0,y0,3] else d2:=
Value[p,x0,y0,4];
    if d1.V>d2.V then d2:=d1;
    Value[p,x0,y0,0].VN:=d2.VN;
    Value[p,x0,y0,0].D:=d2.D;
    Value[p,x0,y0,0].RD:=d2.RD;
    Value[p,x0,y0,0].LD:=d2.LD;
    Value[p,x0,y0,0].RB:=d2.RB;
    Value[p,x0,y0,0].LB:=d2.LB;
  end;
procedure VAdd(x0,y0,dir,p:Byte);{计算空白处(x0,y0)的价值。}
  var
    dx,dy:Integer;
    x,y,i,_p:Byte;
    out:Boolean;
  begin
    dx:=Delta[dir,0];dy:=Delta[dir,1];
    if p=1 then _p:=2 else _p:=1;

    x:=x0;y:=y0;i:=0;out:=false;
    repeat
      x:=x+dx;y:=y+dy;
      Inc(i);
      if (i>4)or(Order[x,y]=$ff)or(Order[x,y]=_p) then out:=True;
      if Order[x,y]=0 then VD(x,y,dir,p);
    until out;

    x:=x0;y:=y0;i:=0;out:=false;
    repeat
      x:=x-dx;y:=y-dy;
      Inc(i);
      if (i>4)or(Order[x,y]=$ff)or(Order[x,y]=_p) then out:=True;
      if Order[x,y]=0 then VD(x,y,dir,p);
    until out;
  end;
procedure TPut(x,y,p:Byte);{下一步棋,计算其周围的空白处的价值。}
  var
    x0,y0:Byte;
    d1,d2:ValueDot;
  begin
    if Order[x,y]=0 then
      begin
        PutChess(x,y,p);
        VAdd(x,y,1,2);
        VAdd(x,y,2,2);
        VAdd(x,y,3,2);
        VAdd(x,y,4,2);

        VAdd(x,y,1,1);
        VAdd(x,y,2,1);
        VAdd(x,y,3,1);
        VAdd(x,y,4,1);
      end;
  end;
procedure Ps(x,y:Byte;s:string);{调试程序时用}
  var
    i:Byte;
  begin
    for i:=2 to Length(s) do
      case s[1] of
        '-':
            begin
              x:=x+1;TPut(x,y,Ord(s[i])-48);
            end;
        '|':
            begin
              y:=y+1;TPut(x,y,Ord(s[i])-48);
            end;
        '\':
            begin
              x:=x+1;y:=y+1;TPut(x,y,Ord(s[i])-48);
            end;
        '/':
            begin
              x:=x-1;y:=y+1;TPut(x,y,Ord(s[i])-48);
            end;
      end;
  end;
function CheckC(p,n:Byte):Word;
{整理各点的价值,并整理成到记录棋子条的数组中。}
{p代表玩家的代码,1为电脑或为玩家;n是几粒棋。}
  var
    i,j:Byte;
    t:Word;
  begin
    t:=0;
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        if Value[p,i,j,0].V>=VV[n] then
          begin
            Inc(t);
            ValueC[p,t,n].X:=i;
            ValueC[p,t,n].Y:=j;
            ValueC[p,t,n].V:=Value[p,i,j,0].V;
            ValueC[p,t,n].VN:=Value[p,i,j,0].VN;
            ValueC[p,t,n].D:=Value[p,i,j,0].D;
            ValueC[p,t,n].RD:=Value[p,i,j,0].RD;
            ValueC[p,t,n].LD:=Value[p,i,j,0].LD;
            ValueC[p,t,n].RB:=Value[p,i,j,0].RB;
            ValueC[p,t,n].LB:=Value[p,i,j,0].LB;
          end;
    ValueC[p,0,n].V:=t;CheckC:=t;
  end;
procedure SortC(p,n,xx:Byte);{把每一空的地方的值排队,以便下最有价值的一步棋。}
{xx表示是1时按价值排,2时按是否两边有空白来排,差不多的,只是走起来,不同。}
  var
    t,i,j:Word;
    t0:ValueD;
  begin
    t:=ValueC[p,0,n].V;
    for i:=1 to t-1 do
      for j:=i+1 to t do
        begin
          if xx=1 then
          begin
            if ValueC[p,i,n].V<ValueC[p,j,n].V then
              begin
                t0:=ValueC[p,i,n];ValueC[p,i,n]:=ValueC[p,j,n];ValueC[p,j,n]:=t0;
              end
            else
              if ValueC[p,i,n].V=ValueC[p,j,n].V then
                if ValueC[p,i,n].D>ValueC[p,j,n].D then
                  begin
                    t0:=ValueC[p,i,n];ValueC[p,i,n]:=ValueC[p,j,n];ValueC[p,j,n]:=t0;
                  end;
          end;
          if xx=2 then
          begin
            if ValueC[p,i,n].D>ValueC[p,j,n].D then
              begin
                t0:=ValueC[p,i,n];ValueC[p,i,n]:=ValueC[p,j,n];ValueC[p,j,n]:=t0;
              end
            else
              if ValueC[p,i,n].D=ValueC[p,j,n].D then
                if ValueC[p,i,n].V<ValueC[p,j,n].V then
                  begin
                    t0:=ValueC[p,i,n];ValueC[p,i,n]:=ValueC[p,j,n];ValueC[p,j,n]:=t0;
                  end;
          end;
        end;
  end;
procedure PC(p:Byte);
  var
    _p,x,y,i,j,k,s,t:Byte;
    b:Boolean;
  begin
    if p=1 then _p:=2 else _p:=1;{这一行是为了可以方便地更改人走先还是走后。}
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        if Value[p,i,j,0].VN=4 then begin TPut(i,j,p);Exit;end;
        {走有四粒的}
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        if Value[_p,i,j,0].VN=4 then begin TPut(i,j,p);Exit;end;
        {防有四粒的}
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        if (Value[p,i,j,0].VN=3) and (Value[p,i,j,0].V>=VV[3]) and not(Value[p,i,j,0].LB)
            and not(Value[p,i,j,0].RB) and (Value[p,i,j,0].D<=5) then
                begin TPut(i,j,p);Exit;end;
        {走有三粒的,如此类推。}
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        begin
          if (Value[p,i,j,0].VN=3) then
            begin
              s:=0;
              if Value[p,i,j,1].VN=3 then Inc(s);
              if Value[p,i,j,2].VN=3 then Inc(s);
              if Value[p,i,j,3].VN=3 then Inc(s);
              if Value[p,i,j,4].VN=3 then Inc(s);
              if s>=2 then begin TPut(i,j,p);Exit;end;
              b:=False;
              for k:=1 to 4 do
                if (Value[p,i,j,k].V=VV[2]) then b:=True;
              if b then begin TPut(i,j,p);Exit;end;
{这里走入经验的陷阱,究竟怎样走半三粒的,和两粒交叉的,是先防还是先攻,
我弄不明白。在此调试可提高程序智力。}
              {Follow no way}
              if Value[p,i,j,0].V>=VV[3] then
                begin
                  s:=0;
                  for k:=1 to 4 do
                    if (Value[_p,i,j,k].V=VV[2])and(
                        (Value[_p,i,j,k].D=1)or(Value[_p,i,j,k].D=2)
                         or(Value[_p,i,j,k].D=5)or(Value[_p,i,j,k].D=10) )
                      then Inc(s);
                  if s>1 then begin TPut(i,j,p);Exit;end;
                end;
            end;
        end;

    s:=0;
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        if (Value[_p,i,j,0].V>=VV[3]) then Inc(s);
    if s>4 then
      for i:=1 to ChessW do
        for j:=1 to ChessW do
          if (Value[p,i,j,0].VN=3)and(Value[p,i,j,0].D<=5) then
            begin TPut(i,j,p);Exit;end;

    for i:=1 to ChessW do
      for j:=1 to ChessW do
        begin
          if (Value[_p,i,j,0].VN=3) then
            begin
              if (Value[_p,i,j,0].V>=VV[3]) and not(Value[_p,i,j,0].LB)
                 and not(Value[_p,i,j,0].RB) and (Value[_p,i,j,0].D<=5) then
                begin TPut(i,j,p);Exit;end;
              s:=0;
              if Value[_p,i,j,1].VN=3 then Inc(s);
              if Value[_p,i,j,2].VN=3 then Inc(s);
              if Value[_p,i,j,3].VN=3 then Inc(s);
              if Value[_p,i,j,4].VN=3 then Inc(s);
              if s>=2 then begin TPut(i,j,p);Exit;end;
              b:=False;
              for k:=1 to 4 do
                if (Value[_p,i,j,k].V=VV[2]) then b:=True;
              if b then begin TPut(i,j,p);Exit;end;
            end;
        end;
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        begin
          s:=0;
          for k:=1 to 4 do
            if (Value[p,i,j,k].V=VV[2])and(
                  (Value[p,i,j,k].D=1)or(Value[p,i,j,k].D=2)
                   or(Value[p,i,j,k].D=5)or(Value[p,i,j,k].D=10) )
              then Inc(s);
          if s>1 then begin TPut(i,j,p);Exit;end;
        end;
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        begin
          s:=0;
          for k:=1 to 4 do
            if (Value[_p,i,j,k].V=VV[2])and(
                  (Value[_p,i,j,k].D=1)or(Value[_p,i,j,k].D=2)
                   or(Value[_p,i,j,k].D=5)or(Value[_p,i,j,k].D=10) )
              then Inc(s);
          if s>1 then begin TPut(i,j,p);Exit;end;
        end;
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        if (Value[p,i,j,0].V>=VV[3]) then begin TPut(i,j,p);Exit;end;

    for i:=1 to ChessW do
      for j:=1 to ChessW do
        if (Value[p,i,j,0].VN=2) and (Value[p,i,j,0].V>=VV[2]) and not(Value[p,i,j,0].LB)
            and not(Value[p,i,j,0].RB) and (Value[p,i,j,0].D<=5) then
                begin TPut(i,j,p);Exit;end;
    if CheckC(p,2)>0 then
      begin
        SortC(p,2,1);
        TPut(ValueC[p,1,2].X,ValueC[p,1,2].Y,p);
        Exit;
      end;
    for i:=1 to ChessW do
      for j:=1 to ChessW do
        if (Value[p,i,j,0].VN=2) and (Value[p,i,j,0].V>=VV[2]) and not(Value[p,i,j,0].LB)
            and not(Value[p,i,j,0].RB) and (Value[p,i,j,0].D<=5) then
                begin TPut(i,j,p);Exit;end;
    if CheckC(_p,2)>0 then
      begin
        SortC(_p,2,2);
        TPut(ValueC[_p,1,2].X,ValueC[_p,1,2].Y,p);
        Exit;
      end;

    if CheckC(p,1)>0 then
      begin
        SortC(p,1,2);
        TPut(ValueC[p,1,1].X,ValueC[p,1,1].Y,p);
        Exit;
      end;
    if JustBegin then
      if CheckC(_p,1)>0 then
        begin        {棋局刚开始反击走法:紧紧贴住。}
          SortC(_p,1,2);
          t:=ValueC[_p,0,1].V;
          if t>3 then t:=Random(8)+1;
          TPut(ValueC[_p,t,1].X,ValueC[_p,t,1].Y,p);
          JustBegin:=False;
          Exit;
        end;
    begin{第一步随机}
      x:=(ChessW div 3)+Random(ChessW div 3);
      y:=(ChessW div 3)+Random(ChessW div 3);
      TPut(x,y,p);
    end;

    Write('Fail');{调试程序用}
  end;
procedure Wait;
  var
    ch:Char;
  begin
    repeat
    until KeyPressed;
    ch:=ReadKey;
  end;
var
  tx,ty,dt:Word;ch:Char;
begin
  InitChess;
  repeat
{    ManTake(2);  {人走一步}
{    Wait;}
    Pc(2);
    if CheckWin(2) then begin write('Man win');halt;end;
{    Wait;}
    ManTake(1);
{    Pc(1);       {电脑走一步}
    if CheckWin(1) then begin write('PC win');halt;end;
  until FALSE;{无直接退出,只有一方输才结束。}
end.



Remark
705行的五子棋高效pascal代码!
Source Link
本记录所在类别:
本记录相关记录: