uses GRAPH,CRT,VGA;
Const
 n      = 10;
 NameX  = 'Hel';
 NameO  = 'Hel2';
 ColorX = LightBlue;
 ColorO = LightRed;
 PoleY1 = 110;
 PoleL  = 460-PoleY1;
 Cell   = PoleL / n;
 PoleX1 = round(320 - (Cell*n) / 2);
 PoleX2 = round(320 + (Cell*n) / 2);
 PoleY2 = round(PoleY1+n*cell);
 TimeT  = 15*25*2;
 DelX   = round(TimeT/Cell/2);
 DelO   = round(TimeT/360);

Type TPole    = array [1..n,1..n] of byte;

Var
  Pole  : TPole;
  TP    : Tpole;
  Ex    : boolean;
  Win   : byte;
  xc,yc : byte;
  count : 0..n*n+1;
  ENDS  : array [1..5] of pointtype;

{$I Turn1.inc}
{$I Turn2.inc}

Type TurnProc = procedure(cx:byte;var x,y:byte);

const
  TurnX : TurnProc=Turn1;
  TurnO : TurnProc=Turn2;
{---------------------------}
Procedure Init;
Var
  i,j : integer;
Begin
  for i := -4 to n+4 do for j:= -4 to n+4 do pole[i,j] :=0;
  InitVGA;
  SetTextStyle(TriplexFont,HORIZDIR,4);
  SetTextJustify(CenterText,BottomText);
  SetFillStyle(XHATCHFILL,Blue);
  Bar(0,0,GetMaxX,GetMaxY);
  SetFillStyle(SolidFill,Black);
  Bar(10,10,630,470);
  SetCOlor(White);
  OutTextXY(320,40,'Битва программ.');
  OutTextXY(320,40+TextHeight('Б')+5,'Крестики-Нолики.');
  SetColor(ColorX);
  SetTextJustify(LeftText,BottomText);
  OutTextXY(10,100,NameX);
  SetLineStyle(SolidLn,0,ThickWidth);
  Line(30,20,70,60);
  Line(70,20,30,60);
  SetColor(ColorO);
  Arc(590,40,0,360,20);
  SetTextJustify(RightText,BottomText);
  OutTextXY(630,100,NameO);
  SetLineStyle(SolidLn,0,NormWidth);
  SetColor(LightGray);
{  Rectangle(PoleX1,PoleY1,PoleX2,PoleY2);}
  For i := 0 to n do begin
    Line(round(PoleX1+Cell*i),PoleY1,round(PoleX1+Cell*i),PoleY2);
    Line(PoleX1,round(PoleY1+Cell*i),PoleX2,round(PoleY1+Cell*i));
  end;
End;{Init}
{--------------------------}

Procedure DrawTurn(cn,x,y:byte);
Var
 i,size : integer;
Begin
 if cn = 1 then
  begin
    SetColor(ColorX);
    size := round(cell-2)-1;
    MoveTo(round(PoleX1+(x-1)*Cell+1),round(PoleY1+(y-1)*Cell+1));
    For i := 1 to size do begin LineRel(1,1);delay(delX);end;
    MoveTo(round(PoleX1+x*Cell-1),round(PoleY1+(y-1)*Cell+1));
    For i := 1 to size do begin LineRel(-1,1);delay(delX);end;
    Pole[x,y] := 1;
  end
 else
  begin
    setColor(ColorO);
    For i := 1 to 360 do begin
      Arc(round(PoleX1+(x-1)*Cell+(Cell / 2)),round(PoleY1+(y-1)*Cell+(Cell / 2))
          ,0,i,round((cell-2) / 2-1));
      delay(DelO);
    end;
    Pole[x,y] := 2;
  end;
End;{DrawTurn}
{---------------------------}
Function IsWin(x,y:byte):byte;
var
 x1,y1 : byte;
 k1,k2,l1,l2 : byte;
 res : byte;
begin
 res := 0;
 if x-4<1 then k1 := 1 else k1 := x - 4;
 if x+4>n then k2 := n else k2 := x + 4;
 if y-4<1 then l1 := 1 else l1 := y - 4;
 if y+4>n then l2 := n else l2 := y + 4;
 for x1 := k1 to k2 do
   for y1 := l1 to l2 do
     if (pole[x1,y1]<>0) then begin
       if ((pole[x1,y1]=pole[x1,y1-2]) and
           (pole[x1,y1]=pole[x1,y1-1]) and
           (pole[x1,y1]=pole[x1,y1+1]) and
           (pole[x1,y1]=pole[x1,y1+2])) then
            begin
             res := pole[x1,y1];
             ENDS[1].x := x1;
             ENDS[1].y := y1-2;
             ENDS[2].x := x1;
             ENDS[2].y := y1-1;
             ENDS[3].x := x1;
             ENDS[3].y := y1;
             ENDS[4].x := x1;
             ENDS[4].y := y1+1;
             ENDS[5].x := x1;
             ENDS[5].y := y1+2;
            end;
       if ((pole[x1,y1]=pole[x1-2,y1]) and
           (pole[x1,y1]=pole[x1-1,y1]) and
           (pole[x1,y1]=pole[x1+1,y1]) and
           (pole[x1,y1]=pole[x1+2,y1])) then
            begin
             res := pole[x1,y1];
             ENDS[1].x := x1-2;
             ENDS[1].y := y1;
             ENDS[2].x := x1-1;
             ENDS[2].y := y1;
             ENDS[3].x := x1;
             ENDS[3].y := y1;
             ENDS[4].x := x1+1;
             ENDS[4].y := y1;
             ENDS[5].x := x1+2;
             ENDS[5].y := y1;
            end;
       if ((pole[x1,y1]=pole[x1-2,y1-2]) and
           (pole[x1,y1]=pole[x1-1,y1-1]) and
           (pole[x1,y1]=pole[x1+1,y1+1]) and
           (pole[x1,y1]=pole[x1+2,y1+2])) then
            begin
             res := pole[x1,y1];
             ENDS[1].x := x1-2;
             ENDS[1].y := y1-2;
             ENDS[2].x := x1-1;
             ENDS[2].y := y1-1;
             ENDS[3].x := x1;
             ENDS[3].y := y1;
             ENDS[4].x := x1+1;
             ENDS[4].y := y1+1;
             ENDS[5].x := x1+2;
             ENDS[5].y := y1+2;
            end;
       if  ((pole[x1,y1]=pole[x1+2,y1-2]) and
           (pole[x1,y1]=pole[x1+1,y1-1]) and
           (pole[x1,y1]=pole[x1-1,y1+1]) and
           (pole[x1,y1]=pole[x1-2,y1+2])) then
            begin
             res := pole[x1,y1];
             ENDS[1].x := x1+2;
             ENDS[1].y := y1-2;
             ENDS[2].x := x1+1;
             ENDS[2].y := y1-1;
             ENDS[3].x := x1;
             ENDS[3].y := y1;
             ENDS[4].x := x1-1;
             ENDS[4].y := y1+1;
             ENDS[5].x := x1-2;
             ENDS[5].y := y1+2;
            end;
            end;
 IsWin := Res;
end;{IsWin}
{---------------------------}
Function IsLeg(x,y:byte):boolean;
var res:boolean; i,j : byte;
begin
  res := true;
  if not (x in [1..n]) then
    res := false;
  if not (y in [1..n]) then
    res := false;
  for i := 1 to n do for j := 1 to n do if pole[i,j] <> tp[i,j] then
    res := false;
  if tp[x,y] <> 0 then
    res := false;
  pole := tp;
  IsLeg:=res;
end;{IsLeg}
Procedure DrawWin;
var i : byte;
Begin
  SetColor(LightGreen);
  for i := 1 to 5 do Rectangle(round(PoleX1+(ENDS[i].x-1)*cell),
                     round(PoleY1+(ENDS[i].y-1)*cell),
                     round(PoleX1+(ENDS[i].x)*cell),
                     round(PoleY1+(ENDS[i].y)*cell));
End;
{-------------------------}
Procedure GameOver(c : byte);
Var
 sc,s1 : string;
Begin
  SetTextStyle(TriplexFont,HorizDir,3);
  SetTextJustify(1,1);
  str(count,sc);
  Case c of
   1: begin
        DrawWin;
        SetColor(11);
        sc := 'Победила команда '+NameX+' на '+sc+' ходу';
        OutTextXY(320,300,sc);
        Ex := true;
      end;
   2: begin
        DrawWin;
        SetColor(11);
        sc := 'Победила команда '+NameO+' на '+sc+' ходу';
        OutTextXY(320,300,sc);
        Ex := true;
      end;
   3: begin
        sc := 'Победила команда '+NameO;
        s1 := 'вследствие тех. поражения команды '+NameX;
        SetColor(11);
        OutTextXY(320,300,sc);
        OutTextXY(320,320,s1);
        Ex := true;
      end;
   4: begin
        sc := 'Победила команда '+NameX;
        s1 := 'вследствие тех. поражения команды '+NameO;
        SetColor(11);
        OutTextXY(320,300,sc);
        OutTextXY(320,320,s1);
        Ex := true;
      end;
   5: begin
        sc := 'Ничья!';
        SetColor(11);
        OutTextXY(320,300,sc);
        Ex := true;
      end;
   end;
  SetTextStyle(TriplexFont,HorizDir,8);
  SetColor(Yellow);
  OutTextXY(320,200,'Игра Окончена!');
End;{GameOver}
{------------------------}
BEGIN
  Init;
  ex := false;
  count := 0;
  repeat
    if KeyPressed then begin if ReadKey = #27 then GameOver(5) end else begin
    tp := pole;
    TurnX(1,xc,yc);
    if not isLeg(xc,yc) then GameOver(3)
    else begin
    inc(count);
    DrawTurn(1,xc,yc);
    win := iswin(xc,yc);
    if (count=n*n) then GameOver(5) else begin
    if Win <> 0 then GameOver(1) else
    begin
      tp := pole;
      TurnO(2,xc,yc);
      if not isLeg(xc,yc) then gameover(4)
      else
      begin
       DrawTurn(2,xc,yc);
       Inc(count);
       win := iswin(xc,yc);
       if (count=n*n) then GameOver(5) else begin
        if Win <> 0 then GameOver(2);
      end;
    end;
    end;
    end;
    end;
    end;
  until Ex;
  ReadKey;
  CloseGraph;
END.