Программа крестики-нолики

USES
  CRT,
  Graph;
TYPE
  Line=ARRAY[0..14] OF Integer;
CONST
  l1:Line=(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14);
  l2:Line=(15,16,17,18,19,20,21,22,23,24,25,26,27,28,29);
  l3:Line=(30,31,32,33,34,35,36,37,38,39,40,41,42,43,44);
  l4:Line=(45,46,47,48,49,50,51,52,53,54,55,56,57,58,59);
  l5:Line=(60,61,62,63,64,65,66,67,68,69,70,71,72,73,74);
  l6:Line=(75,76,77,78,79,80,81,82,83,84,85,86,87,88,89);
  l7:Line=(90,91,92,93,94,95,96,97,98,99,100,101,102,103,104);
  l8:Line=(105,106,107,108,109,110,111,112,113,114,115,116,117,118,119);
  l9:Line=(120,121,122,123,124,125,126,127,128,129,130,131,132,133,134);
  l10:Line=(135,136,137,138,139,140,141,142,143,144,145,146,147,148,149);
  l11:Line=(150,151,152,153,154,155,156,157,158,159,160,161,162,163,164);
  l12:Line=(165,166,167,168,169,170,171,172,173,174,175,176,177,178,179);
  l13:Line=(180,181,182,183,184,185,186,187,188,189,190,191,192,193,194);
  l14:Line=(195,196,197,198,199,200,201,202,203,204,205,206,207,208,209);
  l15:Line=(210,211,212,213,214,215,216,217,218,219,220,221,222,223,224);
  l16:Line=(0,15,30,45,60,75,90,105,120,135,150,165,180,195,210);
  l17:Line=(1,16,31,46,61,76,91,106,121,136,151,166,181,196,211);
  l18:Line=(2,17,32,47,62,77,92,107,122,137,152,167,182,197,212);
  l19:Line=(3,18,33,48,63,78,93,108,123,138,153,168,183,198,213);
  l20:Line=(4,19,34,49,64,79,94,109,124,139,154,169,184,199,214);
  l21:Line=(5,20,35,50,65,80,95,110,125,140,155,170,185,200,215);
  l22:Line=(6,21,36,51,66,81,96,111,126,141,156,171,186,201,216);
  l23:Line=(7,22,37,52,67,82,97,112,127,142,157,172,187,202,217);
  l24:Line=(8,23,38,53,68,83,98,113,128,143,158,173,188,203,218);
  l25:Line=(9,24,39,54,69,84,99,114,129,144,159,174,189,204,219);
  l26:Line=(10,25,40,55,70,85,100,115,130,145,160,175,190,205,220);
  l27:Line=(11,26,41,56,71,86,101,116,131,146,161,176,191,206,221);
  l28:Line=(12,27,42,57,72,87,102,117,132,147,162,177,192,207,222);
  l29:Line=(13,28,43,58,73,88,103,118,133,148,163,178,193,208,223);
  l30:Line=(14,29,44,59,74,89,104,119,134,149,164,179,194,209,224);
  l31:Line=(4,18,32,46,60,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1);
  l32:Line=(5,19,33,47,61,75,-1,-1,-1,-1,-1,-1,-1,-1,-1);
  l33:Line=(6,20,34,48,62,76,90,-1,-1,-1,-1,-1,-1,-1,-1);
  l34:Line=(7,21,35,49,63,77,91,105,-1,-1,-1,-1,-1,-1,-1);
  l35:Line=(8,22,36,50,64,78,92,106,120,-1,-1,-1,-1,-1,-1);
  l36:Line=(9,23,37,51,65,79,93,107,121,135,-1,-1,-1,-1,-1);
  l37:Line=(10,24,38,52,66,80,94,108,122,136,150,-1,-1,-1,-1);
  l38:Line=(11,25,39,53,67,81,95,109,123,137,151,165,-1,-1,-1);
  l39:Line=(12,26,40,54,68,82,96,110,124,138,152,166,180,-1,-1);
  l40:Line=(13,27,41,55,69,83,97,111,125,139,153,167,181,195,-1);
  l41:Line=(14,28,42,56,70,84,98,112,126,140,154,168,182,196,210);
  l42:Line=(29,43,57,71,85,99,113,127,141,155,169,183,197,211,-1);
  l43:Line=(44,58,72,86,100,114,128,142,156,170,184,198,212,-1,-1);
  l44:Line=(59,73,87,101,115,129,143,157,171,185,199,213,-1,-1,-1);
  l45:Line=(74,88,102,116,130,144,158,172,186,200,214,-1,-1,-1,-1);
  l46:Line=(89,103,117,131,145,159,173,187,201,215,-1,-1,-1,-1,-1);
  l47:Line=(104,118,132,146,160,174,188,202,216,-1,-1,-1,-1,-1,-1);
  l48:Line=(119,133,147,161,175,189,203,217,-1,-1,-1,-1,-1,-1,-1);
  l49:Line=(134,148,162,176,190,204,218,-1,-1,-1,-1,-1,-1,-1,-1);
  l50:Line=(149,163,177,191,205,219,-1,-1,-1,-1,-1,-1,-1,-1,-1);
  l51:Line=(164,178,192,206,220,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1);
  l52:Line=(0,16,32,48,64,80,96,112,128,144,160,176,192,208,224);
  l53:Line=(1,17,33,49,65,81,97,113,129,145,161,177,193,209,-1);
  l54:Line=(2,18,34,50,66,82,98,114,130,146,162,178,194,-1,-1);
  l55:Line=(3,19,35,51,67,83,99,115,131,147,163,179,-1,-1,-1);
  l56:Line=(4,20,36,52,68,84,100,116,132,148,164,-1,-1,-1,-1);
  l57:Line=(5,21,37,53,69,85,101,117,133,149,-1,-1,-1,-1,-1);
  l58:Line=(6,22,38,54,70,86,102,118,134,-1,-1,-1,-1,-1,-1);
  l59:Line=(7,23,39,55,71,87,103,119,-1,-1,-1,-1,-1,-1,-1);
  l60:Line=(8,24,40,56,72,88,104,-1,-1,-1,-1,-1,-1,-1,-1);
  l61:Line=(9,25,41,57,73,89,-1,-1,-1,-1,-1,-1,-1,-1,-1);
  l62:Line=(10,26,42,58,74,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1);
  l63:Line=(15,31,47,63,79,95,111,127,143,159,175,191,207,223,-1);
  l64:Line=(30,46,62,78,94,110,126,142,158,174,190,206,222,-1,-1);
  l65:Line=(45,61,77,93,109,125,141,157,173,189,205,221,-1,-1,-1);
  l66:Line=(60,76,92,108,124,140,156,172,188,204,220,-1,-1,-1,-1);
  l67:Line=(75,91,107,123,139,155,171,187,203,219,-1,-1,-1,-1,-1);
  l68:Line=(90,106,122,138,154,170,186,202,218,-1,-1,-1,-1,-1,-1);
  l69:Line=(105,121,137,153,169,185,201,217,-1,-1,-1,-1,-1,-1,-1);
  l70:Line=(120,136,152,168,184,200,216,-1,-1,-1,-1,-1,-1,-1,-1);
  l71:Line=(135,151,167,183,199,215,-1,-1,-1,-1,-1,-1,-1,-1,-1);
  l72:Line=(150,166,182,198,214,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1);
VAR
  gd,gm:Integer;
  i,j:Integer;
  a:ARRAY[0..224] OF Integer;
  k,q,r:Integer;
  ch:Char;
  l:ARRAY[0..71] OF Line;
  w:ARRAY[0..4] OF Integer;
  g:ARRAY[0..224] OF LongInt;
  game_over:Boolean;
PROCEDURE DrawField(i:Integer;j:Integer;s:Integer;h:Integer);
VAR
  x,y,c:Integer;
  ss:String;
BEGIN
  x:=(i*2+1)*15;
  y:=(j*2+1)*15;
  CASE h OF
    0:c:=(i+j) MOD 2+7;
    1:c:=4;
    2:c:=14;
  END;
  SetFillStyle(1,c);
  Bar(x,y,x+30,y+30);
  CASE s OF
    1:BEGIN
      SetFillStyle(1,1);
      Circle(x+15,y+15,10);
      Circle(x+15,y+15,5);
      FloodFill(x+10,y+10,15);
    END;
    2:BEGIN
      SetFillStyle(1,2);
      MoveTo(x+6,y+6);
      LineRel(3,0);
      LineRel(6,6);
      LineRel(6,-6);
      LineRel(3,0);
      LineRel(0,3);
      LineRel(-6,6);
      LineRel(6,6);
      LIneRel(0,3);
      LineRel(-3,0);
      LineRel(-6,-6);
      LineRel(-6,6);
      LineRel(-3,0);
      LineRel(0,-3);
      LIneRel(6,-6);
      LineRel(-6,-6);
      LIneRel(0,-3);
      FloodFill(x+10,y+10,15);
    END;
  END;
  {Str(g[i+j*15],ss);   Vyvod znachenii koefiicienta
  SetColor(0);          opasnosti v celyax otladki.
  IF g[i+j*15]<10000 THEN OutTextXY(x,y,ss) ELSE OutTextXY(x,y,'Inf');
  SetColor(15);}
END;
FUNCTION CheckVictory:Integer;
VAR
  i,j,q,v:Integer;
  w1,w2:Boolean;
BEGIN
  v:=0;
  FOR i:=0 TO 71 DO BEGIN
    FOR j:=0 TO 10 DO BEGIN
      w1:=TRUE;
      w2:=TRUE;
      FOR q:=0 TO 4 DO BEGIN
        w[q]:=l[i][j+q];
        IF w[q]=-1 THEN BEGIN
          w1:=FALSE;
          w2:=FALSE;
        END
        ELSE BEGIN
          IF a[w[q]]<>1 THEN w1:=FALSE;
          IF a[w[q]]<>2 THEN w2:=FALSE;
        END;
      END;
      IF w1 THEN v:=1;
      IF w2 THEN v:=2;
      IF v<>0 THEN break;
    END;
    IF v<>0 THEN break;
  END;
  CheckVictory:=v;
END;
FUNCTION GetResponse:Integer;
VAR
  i,j,k,q,z,r,ii,jj:Integer;
  gmax:LongInt;
  f:Boolean;
BEGIN
  r:=-1;
  FOR k:=0 TO 224 DO BEGIN
    IF a[k]=0 THEN BEGIN
      r:=k;
      break;
    END;
  END;
  IF r<>-1 THEN BEGIN
    k:=0;
    FOR i:=0 TO 14 DO BEGIN
      FOR j:=0 TO 14 DO BEGIN
        IF a[k]=0 THEN g[k]:=100-(i-7)*(i-7)-(j-7)*(j-7) ELSE g[k]:=0;
        k:=k+1;
      END;
    END;
    FOR k:=0 TO 224 DO BEGIN
      IF a[k]=2 THEN BEGIN
        IF k MOD 15>0 THEN BEGIN
          IF a[k-1]=0 THEN g[k-1]:=g[k-1]+1000;
          IF k>14 THEN IF a[k-16]=0 THEN g[k-16]:=g[k-16]+1000;
          IF k<210 THEN IF a[k+14]=0 THEN g[k+14]:=g[k+14]+1000;
        END;
        IF k MOD 15<14 THEN BEGIN
          IF a[k+1]=0 THEN g[k+1]:=g[k+1]+1000;
          IF k>14 THEN IF a[k-14]=0 THEN g[k-14]:=g[k-14]+1000;
          IF k<210 THEN IF a[k+16]=0 THEN g[k+16]:=g[k+16]+1000;
        END;
        IF k>14 THEN IF a[k-15]=0 THEN g[k-15]:=g[k-15]+1000;
        IF k<210 THEN IF a[k+15]=0 THEN g[k+15]:=g[k+15]+1000;
      END;
    END;
    f:=FALSE;
    FOR i:=0 TO 71 DO BEGIN
      FOR j:=0 TO 13 DO BEGIN
        FOR k:=j+1 TO 14 DO BEGIN
          IF (a[l[i][j]]=0) AND (a[l[i][k]]=0) THEN BEGIN
            a[l[i][j]]:=2;
            a[l[i][k]]:=2;
            f:=FALSE;
            FOR q:=0 TO 10 DO BEGIN
              IF (a[l[i][q]]=2) THEN BEGIN
                IF (a[l[i][q+1]]=2) THEN BEGIN
                  IF (a[l[i][q+2]]=2) THEN BEGIN
                    IF (a[l[i][q+3]]=2) THEN BEGIN
                      IF (a[l[i][q+4]]=2) THEN BEGIN
                        f:=TRUE;
                        break;
                      END;
                    END;
                  END;
                END;
              END;
            END;
            a[l[i][j]]:=0;
            a[l[i][k]]:=0;
            IF f THEN BEGIN
              g[l[i][j]]:=g[l[i][j]]+1000000;
              g[l[i][k]]:=g[l[i][k]]+1000000;
              break;
            END;
          END;
          IF f THEN break;
        END;
        If f THEN break;
      END;
    END;
    FOR i:=0 TO 71 DO BEGIN
      FOR j:=0 TO 14 DO BEGIN
        IF a[l[i][j]]=0 THEN BEGIN
          a[l[i][j]]:=2;
          FOR q:=0 TO 10 DO BEGIN
            f:=TRUE;
            FOR z:=0 TO 4 DO BEGIN
              IF a[l[i][q+z]]<>2 THEN BEGIN
                f:=FALSE;
                break;
              END;
            END;
            IF f THEN break;
          END;
          IF f THEN g[l[i][j]]:=1000000000;
          a[l[i][j]]:=0;
        END;
      END;
    END;
    r:=0;
    gmax:=g[0];
    FOR k:=1 TO 224 DO BEGIN
      IF g[k]>gmax THEN BEGIN
        r:=k;
        gmax:=g[k];
      END;
    END;
  END;
  GetResponse:=r;
END;
BEGIN
  l[0]:=l1;
  l[1]:=l2;
  l[2]:=l3;
  l[3]:=l4;
  l[4]:=l5;
  l[5]:=l6;
  l[6]:=l7;
  l[7]:=l8;
  l[8]:=l9;
  l[9]:=l10;
  l[10]:=l11;
  l[11]:=l12;
  l[12]:=l13;
  l[13]:=l14;
  l[14]:=l15;
  l[15]:=l16;
  l[16]:=l17;
  l[17]:=l18;
  l[18]:=l19;
  l[19]:=l20;
  l[20]:=l21;
  l[21]:=l22;
  l[22]:=l23;
  l[23]:=l24;
  l[24]:=l25;
  l[25]:=l26;
  l[26]:=l27;
  l[27]:=l28;
  l[28]:=l29;
  l[29]:=l30;
  l[30]:=l31;
  l[31]:=l32;
  l[32]:=l33;
  l[33]:=l34;
  l[34]:=l35;
  l[35]:=l36;
  l[36]:=l37;
  l[37]:=l38;
  l[38]:=l39;
  l[39]:=l40;
  l[40]:=l41;
  l[41]:=l42;
  l[42]:=l43;
  l[43]:=l44;
  l[44]:=l45;
  l[45]:=l46;
  l[46]:=l47;
  l[47]:=l48;
  l[48]:=l49;
  l[49]:=l50;
  l[50]:=l51;
  l[51]:=l52;
  l[52]:=l53;
  l[53]:=l54;
  l[54]:=l55;
  l[55]:=l56;
  l[56]:=l57;
  l[57]:=l58;
  l[58]:=l59;
  l[59]:=l60;
  l[60]:=l61;
  l[61]:=l62;
  l[62]:=l63;
  l[63]:=l64;
  l[64]:=l65;
  l[65]:=l66;
  l[66]:=l67;
  l[67]:=l68;
  l[68]:=l69;
  l[69]:=l70;
  l[70]:=l71;
  l[71]:=l72;
  game_over:=FALSE;
  gd:=0;
  gm:=0;
  InitGraph(gd,gm,'../BGI/');
  IF GraphResult<>0 THEN BEGIN
     ClrScr;
     WriteLn('Y vas ne klassicheskii Turpo Pascal.');
     WriteLn('Nastroite put k papke graphiki v procedure InitGraph.');
     ReadKey;
  END;
  FOR i:=0 TO 14 DO BEGIN
    FOR j:=0 TO 14 DO BEGIN
      DrawField(i,j,0,0);
    END;
  END;
  DrawField(0,0,0,1);
  FOR i:=0 TO 224 DO a[i]:=0;
  i:=0;
  j:=0;
  k:=0;
  REPEAT
    ch:=ReadKey;
    IF NOT game_over THEN BEGIN
      CASE ch OF
        #32:BEGIN
          IF a[k]=0 THEN BEGIN
            a[k]:=2;
            IF CheckVictory=2 THEN BEGIN
              game_over:=TRUE;
              FOR q:=0 TO 4 DO BEGIN
                k:=w[q];
                i:=k MOD 15;
                j:=k DIV 15;
                DrawField(i,j,a[k],2);
                SetFillStyle(1,1);
                SetTextStyle(1,0,5);
                Bar(30,50,570,105);
                OutTextXY(50,50,'Pozdravlyaem s pobedoi!');
              END;
            END
            ELSE BEGIN
              r:=GetResponse;
              IF r<>-1 THEN BEGIN
                a[r]:=1;
                IF CheckVictory=1 THEN BEGIN
                  game_over:=TRUE;
                  DrawField(i,j,a[k],0);
                  FOR q:=0 TO 4 DO BEGIN
                    k:=w[q];
                    i:=k MOD 15;
                    j:=k DIV 15;
                    DrawField(i,j,a[k],2);
                  END;
                  SetFillStyle(1,1);
                  SetTextStyle(1,0,5);
                  Bar(30,50,590,105);
                  OutTextXY(50,50,'Komp okazalsya umnee :)');
                END
                ELSE BEGIN
                  DrawField(i,j,a[k],1);
                  DrawField(r MOD 15,r DIV 15,a[r],0);
                END;
              END
              ELSE BEGIN
                game_over:=TRUE;
                DrawField(i,j,a[k],0);
              END;
            END;
          END;
        END;
        #72:BEGIN
          IF j>0 THEN BEGIN
            DrawField(i,j,a[k],0);
            j:=j-1;
            k:=k-15;
            DrawField(i,j,a[k],1);
          END;
        END;
        #75:BEGIN
          IF i>0 THEN BEGIN
            DrawField(i,j,a[k],0);
            i:=i-1;
            k:=k-1;
            DrawField(i,j,a[k],1);
          END;
        END;
        #77:BEGIN
          IF i<14 THEN BEGIN
            DrawField(i,j,a[k],0);
            i:=i+1;
            k:=k+1;
            DrawField(i,j,a[k],1);
          END;
        END;
        #80:BEGIN
          IF j<14 THEN BEGIN
            DrawField(i,j,a[k],0);
            j:=j+1;
            k:=k+15;
            DrawField(i,j,a[k],1);
          END;
        END;
      END;
    END;
  UNTIL ch=#27;
  CloseGraph;
END.

  InitGraph(gd,gm,'../BGI/');
  IF GraphResult<>0 THEN BEGIN
     ClrScr;
     WriteLn('Y vas ne klassicheskii Turpo Pascal.');
     WriteLn('Nastroite put k papke graphiki v procedure InitGraph.');
     ReadKey;
  END;
  FOR i:=0 TO 14 DO BEGIN

uses Graph;
const
  n=30;{pixel per field}
  m=5;{image size}
  k=15;{count field}
  {for image}
  x0=m;{begin x}
  x1=n-m;{end x}
  y0=m;{begin y}
  y1=n-m;{end y}
type
  tMass=array[0..n,0..n]of byte;
var
  a,b,mX,mY,SizeImage:integer;
  c:byte;
  x,o,s:pointer;
  Field:tMass;
{Quasi crt:ReadKey}
function GetKey:byte;
  var a:byte;
  begin{GetKey}
    asm
      xor ax,ax
      int 16h
      mov a,ah
    end;
    GetKey:=a;
  end;{GetKey}
{debug - procedure only}
procedure DbgKey;
  begin{DbgKey}
{    GetKey;}
  end;{DbgKey}
{output figure}
procedure ImagePut(a,b:integer;c:pointer;d:integer);
  begin{ImagePut}
    PutImage(m+n*a,m+n*b,c^,d)
  end;{ImagePut}
{Artificial Intelligence}
procedure AIStep(var pole:tMass);
  var a,b:integer;
  begin{AIStep}
    {begin AI for you}
    repeat
      a:=random(k);
      b:=random(k);
    until pole[a,b]=0;
    {end AI for you}
    pole[a,b]:=2;
    ImagePut(a,b,o,NormalPut);
  end;{AIStep}
begin{main}
  a:=detect;
  InitGraph(a,b,'');
  a:=GraphResult;
  if a=grOK then
    begin{graph mode}
      {begin program}
      SizeImage:=ImageSize(0,0,n-2*m,n-2*m);
      {crate x}
      ClearDevice;
      for a:=0 to n do for b:=0 to n do
        if (a in[0..n])and(b in[0..n])and
        ((abs(a-b)<4)or(abs(n-a-b)<4))then PutPixel(a,b,15);
      GetMem(x,SizeImage);
      GetImage(x0,y0,x1,y1,x^);
      DbgKey;
      {create o}
      ClearDevice;
      for a:=0 to 3 do Circle(n div 2,n div 2,(n div 2)-m-a);
      GetMem(o,SizeImage);
      GetImage(x0,y0,x1,y1,o^);
      DbgKey;
      {create +}
      ClearDevice;
      Line(0,n div 2,n,n div 2);
      Line(n div 2,0,n div 2,n);
      Circle(n div 2,n div 2,n div 4);
      GetMem(s,SizeImage);
      GetImage(x0,y0,x1,y1,s^);
      DbgKey;
      {generate field}
      for a:=0 to n do for b:=0 to n do Field[a,b]:=0;
      ClearDevice;
      {show desk}
      for a:=0 to k do Line(n*a,0,n*a,15*n);
      for a:=0 to k do Line(0,n*a,15*n,n*a);
      {begin main loop}
      mX:=0;mY:=0;
      repeat
        {show marker}
        ImagePut(mX,mY,s,XorPut);
        c:=GetKey;
        a:=0;b:=0;
        {hide marker}
        ImagePut(mX,mY,s,XorPut);
        case c of
          57:if Field[mX,mY]=0 then{Space}
            begin
              Field[mX,mY]:=1;
              ImagePut(mX,mY,x,NormalPut);
              AIStep(Field);
            end;
          75:a:=-1;{Left arrow}
          77:a:=1;{Right arrow}
          72:b:=-1;{Up arrow}
          80:b:=1;{Down arrow}
          end;
        {change marker position}
        if((a+mX)in[0..k-1])and((b+mY)in[0..k-1])then
          begin
            mX:=mX+a;
            mY:=mY+b;
          end;
      until c=1;
      {end main loop}
      {fremem}
      FreeMem(x,SizeImage);
      FreeMem(o,SizeImage);
      FreeMem(s,SizeImage);
      {end program}
      GetKey;
      CloseGraph;
    end{graph mode}
    else
    begin{no graph mode}
      {error message}
      writeln('Graph mode error:',GraphErrorMsg(a));
      writeln('Press any key . . .');
      GetKey;
    end{no graph mode}
end.{main}

  n=30;{pixel per field}
  m=5;{image size}
  k=15;{count field}

      for a:=0 to k do Line(n*a,0,n*a,15*n);
      for a:=0 to k do Line(0,n*a,15*n,n*a);

  n=30;{pixel per field}
  m=5;{image size}
  k=15;{count field}

      for a:=0 to k do Line(n*a,0,n*a,15*n);
      for a:=0 to k do Line(0,n*a,15*n,n*a);