实在是没时间解释。= =。。自己看吧。
用了graph,crt,dos单元，最好用fp或者lazarus编译。
1.0.1905版

Program FiveInARow;
uses
  graph,crt,dos;
label
  Ex;
const
  version='Version 1.0.1895 Beta  [2010/08/03]';
  ChessW=19;
  BlankW=24;
  _Color1=Red;
  _Color2=Green;
  Delta:array [1..4,0..1] of Integer=((1,0),(0,1),(1,1),(1,-1));
  VV:array [0..4] of Word=(0,8,64,512,4096);
  EGAMode=16;
  VGAMode=18;
  CGAMode=6;
  IconWidth=300;
  Pri='Neoix Organization';
  WebSite='XXXXXXXXXXXXXXXXXXXX/';
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;
  ValueC:array [1..2,0..ChessW*ChessW,1..4] of ValueD;
  BeginX,BeginY,CurrentX,CurrentY:Word;
  Order:array[0..ChessW+1,0..ChessW+1] of Byte;
  ChessRecord:array[0..ChessW*ChessW,0..2]of integer;
  JustBegin:Boolean;
  R:Registers;
  chose:integer;
  Step:integer;
  i:integer;
  x0:integer;
  i0,j0,ix,jx,iy,jy:integer;
  IconX,IconY,IconWidth0:integer;
  Point:array[1..1024,1..768]of integer;
procedure InitChess;
var
  grDriver: Integer;
  grMode: Integer;
  ErrCode: Integer;
  HalfX,HalfY,H:Word;
  ex,ey,i,j:Word;
  k:integer;
  strtemp:string;
begin
  DirectVideo:=False;
  Randomize;
  JustBegin:=True;
  XXXXX:=0;
  V0.V:=0;V0.D:=25;
  V0.LD:=5;V0.RD:=5;
  XXXXX:=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 halt;
  SetFillStyle(1,White);
  FloodFill(1,1,White);
  IconWidth0:=IconWidth div 5;
  IconX:=(GetMaxX-IconWidth) div 2;
  IconY:=(GetMaxY-IconWidth) div 2;
  SetColor(LightGray);
  SetFillStyle(1,LightGray);
  Circle(IconX+IconWidth0*1+IconWidth0 div 2,IconY+IconWidth0*1+IconWidth0 div 2,IconWidth0*1+IconWidth0 div 2);
  FloodFill(IconX+IconWidth0*1+IconWidth0 div 2,IconY+IconWidth0*1+IconWidth0 div 2,LightGray);
  Circle(IconX+IconWidth-IconWidth0-IconWidth0 div 2,IconY+IconWidth-IconWidth0-IconWidth0 div 2,IconWidth0*1+IconWidth0 div 2);
  FloodFill(IconX+IconWidth-IconWidth0-IconWidth0 div 2,IconY+IconWidth-IconWidth0-IconWidth0 div 2,LightGray);
  SetColor(White);
  SetFillStyle(1,White);
  Circle(IconX+IconWidth-IconWidth0-IconWidth0 div 2,IconY+IconWidth-IconWidth0-IconWidth0 div 2,IconWidth0 div 2);
  FloodFill(IconX+IconWidth-IconWidth0-IconWidth0 div 2,IconY+IconWidth-IconWidth0-IconWidth0 div 2,White);
  Circle(IconX+IconWidth0*1+IconWidth0 div 2,IconY+IconWidth0*1+IconWidth0 div 2,IconWidth0 div 2);
  FloodFill(IconX+IconWidth0*1+IconWidth0 div 2,IconY+IconWidth0*1+IconWidth0 div 2,White);
  for i:=IconY to IconY+IconWidth0 do
    for j:=IconX+IconWidth0*1+IconWidth0 div 2 to IconX+IconWidth do
      PutPixel(j,i,LightGray);
  for i:=IconY+IconWidth0*2 to IconY+IconWidth0*3 do
    for j:=IconX+IconWidth0*1+IconWidth0 div 2 to IconX+IconWidth-(IconWidth0*1+IconWidth0 div 2) do
      PutPixel(j,i,LightGray);
  for i:=IconY+IconWidth0*4 to IconY+IconWidth0*5 do
    for j:=IconX to IconX+IconWidth-(IconWidth0*1+IconWidth0 div 2) do
      PutPixel(j,i,LightGray);
  for i:=IconY+IconWidth0 to IconY+IconWidth0*2 do
    for j:=IconX+IconWidth0*1+IconWidth0 div 2 to IconX+IconWidth-IconWidth0 do
      PutPixel(j,i,White);
  for i:=IconY+IconWidth0*3 to IconY+IconWidth0*4 do
    for j:=IconX+IconWidth0 to IconX+IconWidth-(IconWidth0*1+IconWidth0 div 2) do
      PutPixel(j,i,White);
  for i:=IconX+IconWidth0 to IconX+IconWidth0*2 do
    for j:=IconY+IconWidth0*1+IconWidth0 div 2 to IconY+IconWidth-IconWidth0 do
      if GetPixel(i,j)=LightGray then Point[i,j]:=1;
  for i:=IconX+IconWidth0*3 to IconX+IconWidth0*4 do
    for j:=IconY+IconWidth0 to IconY+IconWidth-(IconWidth0*1+IconWidth0 div 2) do
      if GetPixel(i,j)=LightGray then Point[i,j]:=1;
  SetColor(DarkGray);
  SetFillStyle(1,DarkGray);
  Circle(IconX+IconWidth0*1+IconWidth0 div 2,IconY+IconWidth0*1+IconWidth0 div 2,IconWidth0*1+IconWidth0 div 2);
  FloodFill(IconX+IconWidth0*1+IconWidth0 div 2,IconY+IconWidth0*1+IconWidth0 div 2,DarkGray);
  Circle(IconX+IconWidth-IconWidth0-IconWidth0 div 2,IconY+IconWidth-IconWidth0-IconWidth0 div 2,IconWidth0*1+IconWidth0 div 2);
  FloodFill(IconX+IconWidth-IconWidth0-IconWidth0 div 2,IconY+IconWidth-IconWidth0-IconWidth0 div 2,DarkGray);
  SetColor(White);
  SetFillStyle(1,White);
  Circle(IconX+IconWidth-IconWidth0-IconWidth0 div 2,IconY+IconWidth-IconWidth0-IconWidth0 div 2,IconWidth0 div 2);
  FloodFill(IconX+IconWidth-IconWidth0-IconWidth0 div 2,IconY+IconWidth-IconWidth0-IconWidth0 div 2,White);
  Circle(IconX+IconWidth0*1+IconWidth0 div 2,IconY+IconWidth0*1+IconWidth0 div 2,IconWidth0 div 2);
  FloodFill(IconX+IconWidth0*1+IconWidth0 div 2,IconY+IconWidth0*1+IconWidth0 div 2,White);
  for i:=IconX to IconX+IconWidth0 do
    for j:=IconY+IconWidth0*1+IconWidth0 div 2 to IconY+IconWidth do
      PutPixel(i,j,DarkGray);
  for i:=IconX+IconWidth0*2 to IconX+IconWidth0*3 do
    for j:=IconY+IconWidth0*1+IconWidth0 div 2 to IconY+IconWidth-(IconWidth0*1+IconWidth0 div 2) do
      PutPixel(i,j,DarkGray);
  for i:=IconX+IconWidth0*4 to IconX+IconWidth0*5 do
    for j:=IconY to IconY+IconWidth-(IconWidth0*1+IconWidth0 div 2) do
      PutPixel(i,j,DarkGray);
  for i:=IconX+IconWidth0 to IconX+IconWidth0*2 do
    for j:=IconY+IconWidth0*1+IconWidth0 div 2 to IconY+IconWidth-IconWidth0 do
      if Point[i,j]=1 then PutPixel(i,j,LightGray) else PutPixel(i,j,White);
  for i:=IconX+IconWidth0*3 to IconX+IconWidth0*4 do
    for j:=IconY+IconWidth0 to IconY+IconWidth-(IconWidth0*1+IconWidth0 div 2) do
      if Point[i,j]=1 then PutPixel(i,j,LightGray) else PutPixel(i,j,White);
  for i:=IconX-IconWidth0+IconWidth to IconX+IconWidth do
    for j:=IconY to IconY+IconWidth0 do
      PutPixel(i,j,Yellow);
  for i:=IconX to IconX+IconWidth do
    for j:=IconY to IconY+IconWidth do
      if GetPixel(i,j)<>White then Point[i,j]:=GetPixel(i,j) else Point[i,j]:=0;
  for i:=IconX to IconX+IconWidth do
    for j:=IconY to IconY+IconWidth do
      if Point[i,j]<>0 then PutPixel(i+5,j+5,Black);
  for i:=IconX to IconX+IconWidth do
    for j:=IconY to IconY+IconWidth do
      if Point[i,j]<>0 then PutPixel(i,j,Point[i,j]);
  SetTextStyle(DefaultFont,HorizDir,2);
  for i:=1 to length(pri) do
  begin
    Delay(70);
    SetColor(LightGray);
    OutTextXY((GetMaxX-TextWidth(pri)) div 2+2,IconY+IconWidth+20+2,Copy(pri,1,i));
    SetColor(DarkGray);
    OutTextXY((GetMaxX-TextWidth(pri)) div 2+1,IconY+IconWidth+20+1,Copy(pri,1,i));
    SetColor(Black);
    OutTextXY((GetMaxX-TextWidth(pri)) div 2,IconY+IconWidth+20,Copy(pri,1,i));
  end;
  x0:=IconY+IconWidth+25+TextHeight(pri);
  SetTextStyle(DefaultFont,HorizDir,1);
  for i:=1 to length(website) do
  begin
    Delay(50);
    SetColor(LightGray);
    OutTextXY((GetMaxX-TextWidth(website)) div 2+2,x0,Copy(website,1,i));
    SetColor(DarkGray);
    OutTextXY((GetMaxX-TextWidth(website)) div 2+1,x0,Copy(website,1,i));
    SetColor(Black);
    OutTextXY((GetMaxX-TextWidth(website)) div 2,x0,Copy(website,1,i));
  end;
  Delay(1000);
  CloseGraph;
  InitGraph(grDriver, grMode,'C:\TP\BGI');    
  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);
  Bar(BeginX,BeginY,ex,ey);
  SetColor(White);
  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;
  for i:=1 to ChessW do
  begin
    str(i,strtemp);
    if i<10 then strtemp:='0'+strtemp;
    outtextxy(BeginX+(i-1)*BlankW+5,beginY-15,strtemp);
  end;
  for k:=1 to ChessW do
    outtextxy(BeginX-15,BeginY+(k-1)*BlankW+5,chr(k+96));
  SetTextStyle(DefaultFont,HorizDir,3);
  OutTextXY(10,10,'Five In A Row');
  k:=TextHeight('Five In A Row');
  SetTextStyle(DefaultFont,HorizDir,1);
  OutTextXY(GetMaxX-TextWidth(version)-10,k+10-TextHeight(version),version);
  OutTextXY(75,GetMaxY-23,'Steps');
  SetTextStyle(DefaultFont,HorizDir,2);
  OutTextXY(20,GetMaxY-30,'0');
  Line(0,k+20,GetMaxX,k+20);
  SetTextStyle(DefaultFont,HorizDir,1);
  OutTextXY(10,k+30,'[s:9]lease use the main window to control.');
  case chose of
  1:begin
      SetTextStyle(DefaultFont,HorizDir,2);
      OutTextXY(BeginX-330+32,BeginY,'[s:9]C  ');
      OutTextXY(BeginX-200,BeginY,'[s:9]layer');
    end;
  2:begin
      SetTextStyle(DefaultFont,HorizDir,2);
      OutTextXY(BeginX-330,BeginY,'[s:9]layer');
      OutTextXY(BeginX-200+32,BeginY,'[s:9]C  ');
    end;
  3:begin
      SetTextStyle(DefaultFont,HorizDir,2);
      OutTextXY(BeginX-330,BeginY,'[s:9]layer');
      OutTextXY(BeginX-200,BeginY,'[s:9]layer');
    end;
  4:begin
      SetTextStyle(DefaultFont,HorizDir,2);
      OutTextXY(BeginX-330+32,BeginY,'[s:9]C');
      OutTextXY(BeginX-200+32,BeginY,'[s:9]C');
    end;
  end;
end;
procedure ViewState0(state0:integer);
var
  r:word;
begin
  r:=(BlankW div 2);
  SetColor(black);
  Circle(BeginX-330+48,BeginY+50,r-3);
  SetFillStyle(1,black);
  FloodFill(BeginX-330+48,BeginY+50,black);
  Circle(BeginX-200+48,BeginY+50,r-3);
  SetFillStyle(1,black);
  FloodFill(BeginX-200+48,BeginY+50,black);
  if state0=1 then
  begin
    SetColor(_Color1);
    Circle(BeginX-330+48,BeginY+50,r-3);
    SetFillStyle(1,_Color1);
    FloodFill(BeginX-330+48,BeginY+50,_Color1);
  end
  else
  begin
    SetColor(_Color2);
    Circle(BeginX-200+48,BeginY+50,r-3);
    SetFillStyle(1,_Color2);
    FloodFill(BeginX-200+48,BeginY+50,_Color2);
  end;
end;
procedure ViewResult(state0:integer);
var
  r:word;
begin
  r:=(BlankW div 2);
  SetColor(black);
  Circle(BeginX-330+50,BeginY+50,r-3);
  SetFillStyle(1,black);
  FloodFill(BeginX-330+50,BeginY+50,black);
  Circle(BeginX-200+50,BeginY+50,r-3);
  SetFillStyle(1,black);
  FloodFill(BeginX-200+50,BeginY+50,black);
  SetColor(white);
  if state0=1 then
  begin
    SetTextStyle(DefaultFont,HorizDir,2);
    OutTextXY(BeginX-330+24,BeginY+50,'Win');
  end
  else
  begin
    SetTextStyle(DefaultFont,HorizDir,2);
    OutTextXY(BeginX-200+24,BeginY+50,'Win');
  end;
end;
procedure RecordChess(_x,_y,player:Word);
var
  strtemp:string;
begin
  SetColor(black);
  SetTextStyle(DefaultFont,HorizDir,1);
  for i:=GetMaxY-40 to GetMaxY do
    Line(10,i,74,i);
  Step:=Step+1;
  SetColor(white);
  str(Step,strTemp);
  //strTemp:=strTemp+' Steps';
  SetTextStyle(DefaultFont,HorizDir,2);
  OutTextXY(20,GetMaxY-30,strtemp);
  ChessRecord[Step,0]:=player;
  ChessRecord[Step,1]:=_x;
  ChessRecord[Step,2]:=_y;
  str(_x,strtemp);
  if _x<10 then strtemp:='0'+strtemp;
  strtemp:=chr(_y+96)+' '+strtemp;
  SetTextStyle(DefaultFont,HorizDir,1);
  if player=1 then
    OutTextXY(BeginX-325+(step div 76)*50,BeginY+80+10*((Step mod 76 -1) div 2),strtemp)
  else
    OutTextXY(BeginX-195+(step div 76)*50,BeginY+80+10*((Step mod 76 -1) div 2),strtemp);
end;
procedure PutRect(_x,_y:Word;Erase:Boolean);
var
  r:Word;
begin
  r:=BlankW -2;
  if Erase then SetColor(Black) else SetColor(White);
  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
  recordchess(_x,_y,player);
  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);
var
  ch:Char;
  Take:Boolean;
begin
  Take:=False;
  repeat
    ch:=#0;
    if KeyPressed then
    begin
      ch:=ReadKey;
      GotoXY(12,25);
      write('        ');
      GotoXY(12,25);
      write('#',ord(ch));
    end;
    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;
    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 VD(x0,y0,d,p:Byte);
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;
      Value[p,x0,y0,d].VN:=s0;
      Value[p,x0,y0,d].LD:=l0;
      Value[p,x0,y0,d].RD:=r0;
      Value[p,x0,y0,d].LB:=lb0;
      Value[p,x0,y0,d].RB:=rb0;
      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:=XXXXX;
  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:=XXXXX;
end;
procedure VAdd(x0,y0,dir,p:Byte);
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;
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);
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;
              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;
end;
procedure Wait;
var
  ch:Char;
begin
  repeat
  until KeyPressed;
  ch:=ReadKey;
end;
procedure Pre;
var
  i:integer;
begin
  for i:=1 to 6 do
  begin
    delay(100+random(300));
    write('.');
  end;
  InitChess;
  ViewState0(1);
  writeln('初始化成功');
  writeln('[s:9]reset Successfully');
  writeln;
  writeln('使用方向键和回车键控制');
  writeln('Use directiion keys and enter key to control');
  writeln;
  writeln('单击任何按键开始');
  writeln('Click any key to start');
  writeln;
  writeln;
  TextColor(Black);
  TextBackground(White);
  write(' Command ');
  TextColor(White);
  TextBackground(Black);
end;
var
  tx,ty,dt:Word;ch:Char;
begin
  writeln('Free Pascal IDE Version 1.0.8 [2006/08/21]');
  writeln('Compiler Version 2.0.4');
  writeln('GBD Version GDB 6.2.1');
  writeln;
  randomize;
  writeln('Detect Driver ');
  writeln('XXXXAMode');
  writeln('XXXXAMode');
  writeln('XXXXAMode');
  writeln('Choose graph mode (Auto choose VGA) ? ');
  i:=0;
  repeat
    i:=i+1;
    delay(1000);
    write('.');
  until (keypressed) or (i=7);
  if i<>7 then Ch:=ReadKey else ch:='0';
  writeln;
  R.AH:=0;
  case ch of
  '1':begin
        XXXX:=VGAMode;
        writeln('Chosen VGAMode');
      end;
  '2':begin
        XXXX:=EGAMode;
        writeln('Chosen EGAMode');
      end;
  '3':begin
        XXXX:=CGAMode;
        writeln('Chosen CGAMode');
      end;
  else
    begin
      writeln;
      repeat
        clrscr;
        TextColor(Yellow+blink);
        TextBackground(Red);
        Write('Error');
        delay(1000);
        clrscr;
        TextColor(White);
        TextBackground(Black);
        Write('Error');
        delay(1000);
      until keypressed;
      halt;
    end;
  end;
  Intr(16,R);
  DirectVideo:=False;
  writeln;
  write('[s:9]reset Graph Window ');
  for i:=1 to 3 do
  begin
    delay(100+random(100));
    write('.');
  end;
  writeln;
  write('Loading 936-Chinese Page ');
  delay(200+random(1000));
  writeln;
  writeln;
  writeln('超级五子棋');
  writeln('Five In A Row');
  writeln;
  writeln(version);
  writeln('By Rijn - Neoix');
  writeln;
  delay(200+random(200));
  writeln('1.电脑对玩家 PC(First) Player');
  writeln('2.玩家对电脑 Player(First) PC');
  writeln('3.玩家对玩家 Player Player');
  writeln('4.电脑对电脑 PC PC (Test)');
  write('选择模式 Choose a mode ? ');
  repeat until KeyPressed;
  Ch:=ReadKey;
  chose:=ord(ch)-48;
  Case chose of
    1:begin
        writeln(1);
        Pre;
        wait;
        repeat
          PC(1);
          if CheckWin(1) then begin ViewResult(1);goto Ex;end;
          ViewState0(2);
          ManTake(2);
          if CheckWin(2) then begin ViewResult(2);goto Ex;end;
          ViewState0(1);
        until FALSE;
      end;
    2:begin
        writeln(2);
        Pre;
        repeat
          ManTake(1);
          if CheckWin(1) then begin ViewResult(1);goto Ex;end;
          ViewState0(2);
          Pc(2);
          if CheckWin(2) then begin ViewResult(2);goto Ex;end;
          ViewState0(1);
        until FALSE;
      end;
    3:begin
        writeln(3);
        Pre;
        repeat
          ManTake(1);
          if CheckWin(1) then begin ViewResult(1);goto Ex;end;
          ViewState0(2);
          ManTake(2);
          if CheckWin(2) then begin ViewResult(2);goto Ex;end;
          ViewState0(1);
        until FALSE;
      end;
    4:begin
        writeln(4);
        Pre;
        wait;
        repeat
          PC(1);
          if CheckWin(1) then begin ViewResult(1);goto Ex;end;
          ViewState0(2);
          PC(2);
          if CheckWin(2) then begin ViewResult(2);goto Ex;end;
          ViewState0(1);
        until FALSE;
      end;
    else
      begin
        writeln;
        repeat
          clrscr;
          TextColor(Yellow+blink);
          TextBackground(Red);
          Write('Error');
          delay(1000);
          clrscr;
          TextColor(White);
          TextBackground(Black);
          Write('Error');
          delay(1000);
        until keypressed;
        halt;
      end;
  end;
  Ex:
  TextColor(LightGray);
  TextBackground(Black);
  writeln;
  writeln;
  writeln('游戏结束');
  writeln('Game Over');
  writeln;
  writeln('感谢使用');
  writeln('Thank you for playing');
  writeln('Rijn制作');
  writeln('Made by Rijn');
  writeln('版权归 Neoix Org 所有');
  writeln('Copyright <c> Neoix Org, 2009-2010');
  writeln;
  writeln('单击回车键退出');
  writeln('Click enter to exit');
  readln
end.