program diagment;

uses crt;

var
b: array[1..4,1..4] of char;
control: array[1..2] of boolean;
s: array[1..2] of char;
c: char;
n,i,l: integer;
turn: integer;
abort: boolean;
xb,yb: integer;
temp: string;

procedure plotb(x,y:byte);
var tmp: string;
begin
textbackground(1);
textcolor(15);
gotoxy(x,y);
writeln('ÚÄÂÄÂÄÂÄ¿');
for i := 1 to 4 do begin
  tmp := '';
  gotoxy(x,y+2*i-1);
  for l := 1 to 4 do tmp := tmp + '³' + b[l,i];
  writeln(tmp+'³');
  gotoxy(x,y+2*i);
  writeln('ÃÄÅÄÅÄÅÄ´');
end;
gotoxy(x,y+8);
writeln('ÀÄÁÄÁÄÁÄÙ');
textcolor(14);
for i := 2 to 4 do
  for l := 2 to 4 do begin gotoxy(x+2*l-1,y+2*i-1); writeln(b[l,i]); end;
textcolor(7);
textbackground(0);
end;

procedure getxy(c: char; var x,y: integer);
begin
case upcase(c) of
'1': begin x := 1; y := 1; end;
'2': begin x := 2; y := 1; end;
'3': begin x := 3; y := 1; end;
'4': begin x := 4; y := 1; end;

'Q': begin x := 1; y := 2; end;
'W': begin x := 2; y := 2; end;
'E': begin x := 3; y := 2; end;
'R': begin x := 4; y := 2; end;

'A': begin x := 1; y := 3; end;
'S': begin x := 2; y := 3; end;
'D': begin x := 3; y := 3; end;
'F': begin x := 4; y := 3; end;

'Z': begin x := 1; y := 4; end;
'X': begin x := 2; y := 4; end;
'C': begin x := 3; y := 4; end;
'V': begin x := 4; y := 4; end;

{'`', '-','=','\','+': halt(0); {exit keys}
else begin halt(0); end;
end;
end;



procedure check(gr1,gr2:integer; var ok:boolean);
begin
ok := true;
if b[gr1,gr2]<>' ' then begin ok := false; exit; end;
end;

procedure checkfull;
var ok, full: boolean;
az,bz: integer;
begin
full := true;
for az := 1 to 4 do for bz := 1 to 4 do begin
  check(az, bz, ok);
  if ok then full := false;
  end;
if full then begin
  gotoxy(1,2);
  writeln('Draw!');

  halt(0);
end;
end;

function littlefull: boolean;
var ok,z: boolean;
az,bz: integer;
begin
z := true;
for az := 2 to 4 do for bz := 2 to 4 do begin
  check(az, bz, ok);
  if ok then z := false;
  end;
littlefull:=z;
end;


procedure win(t:integer; var w: boolean);
var j, jj, k, kk, h, hh, q, qq: integer;
begin
w := false;
case t of
1: begin
for j := 1 to 4 do begin
  for jj := 1 to 4 do begin
    if b[j, jj]='X' then begin
       for k := 1 to 4 do begin
         for kk := 1 to 4 do begin
           if (k<>j)and(kk<>jj)and(b[k,kk]='X') then begin
             for h := 1 to 4 do begin
               for hh := 1 to 4 do begin
                 if (h<>k)and(hh<>kk)and(h<>j)and(hh<>jj)and(b[h,hh]='X') then begin
                   for q := 1 to 4 do begin

                     if (q<>j)and(q<>k)and(q<>h)then
                       for qq := 1 to 4 do begin

                       if (qq<>jj)and(qq<>kk)and(qq<>hh)and(b[q,qq]='X') then w:=true;

                     end;
                   end;
                 end;
               end;
             end;
           end;
         end;
       end;
    end;
  end;
end;
end;
2: begin
if (b[2,2]='O')and(b[3,2]='O')and(b[4,2]='O') then w := true;
if (b[2,3]='O')and(b[3,3]='O')and(b[4,3]='O') then w := true;
if (b[2,4]='O')and(b[3,4]='O')and(b[4,4]='O') then w := true;

if (b[2,2]='O')and(b[2,3]='O')and(b[2,4]='O') then w := true;
if (b[3,2]='O')and(b[3,3]='O')and(b[3,4]='O') then w := true;
if (b[4,2]='O')and(b[4,3]='O')and(b[4,4]='O') then w := true;

if (b[2,2]='O')and(b[3,3]='O')and(b[4,4]='O') then w := true;
if (b[2,4]='O')and(b[3,3]='O')and(b[4,2]='O') then w := true;
end;
end;
end;

procedure cpumove(turn: integer);
var x,y,xx,yy: integer;
fb: array[1..4,1..4] of char;
ok, w : boolean;
begin
  w:=false;ok:=false;
  gotoxy(1,1);clreol;
  gotoxy(1,1);write('Thinking...');

for x := 1 to 4 do
  for y := 1 to 4 do fb[x,y]:=b[x,y];



for xx := 1 to 4 do
  for yy := 1 to 4 do begin
    check(xx,yy,ok);
    if ok then b[xx,yy]:=s[turn];
    win(turn,w);
    if w then begin
      writeln('Computer ',turn,' wins!');
      plotb(xb,yb);
      halt(0);

    end;
{          plotb(xb,yb);
          readln;         }
    for x := 1 to 4 do
      for y := 1 to 4 do b[x,y]:=fb[x,y];
  end;

for xx := 1 to 4 do
  for yy := 1 to 4 do begin
    check(xx,yy,ok);
    if ok then b[xx,yy]:=s[3-turn];
    win(3-turn,w);
    if w then begin
         b[xx,yy]:=s[turn];
         w := false;
         exit;
    end;
        for x := 1 to 4 do
      for y := 1 to 4 do b[x,y]:=fb[x,y];

    end;

randomize;
repeat
ok := true;
x:=random(4)+1;y:=random(4)+1;
if (turn=2)and not littlefull then begin x:=random(3)+2;y:=random(3)+2;end;
check(x,y,ok);
until ok;
b[x,y]:=s[turn];
    if w then begin
      writeln('Computer ',turn,' wins!');
      plotb(xb,yb);
      halt(0);

    end;


end;


procedure playermove(turn: integer);
var x,y: integer;
ok, w : boolean;
begin
repeat
ok := true;
  gotoxy(1,1);clreol;
  gotoxy(1,1);write('Player ',turn,', your move: ');
  readln(c);
  getxy(c,x,y);
  check(x,y,ok);
  if ok then begin
    b[x,y] := s[turn];
    win(turn,w);
    if w then begin
      writeln('Player ',turn,' wins!');
      plotb(xb,yb);
      halt(0);
    end;
  end;
until ok;
end;

procedure initplayers;
begin
gotoxy(1,1);
write('Player 1 is Human? [Y/N] (Y): '); readln(c);
case upcase(c) of
'N' : control[1] := true;
end;
write('Player 2 is Human? [Y/N] (Y): '); readln(c);
case upcase(c) of
'N' : control[2] := true;
end;
gotoxy(1,1);
clreol;writeln;
clreol;
end;

begin
xb := 5; yb := 3;
clrscr;

temp:=paramstr(1);
if temp[length(temp)]='?' then begin
  writeln('D - based on the game Diagment by Tyrethali');
  writeln;
  writeln('The idea is simple - player 1, the ''X'' player, tries to put its');
  writeln('stones so that no two of them share the same X and Y coordinate,');
  writeln('while player 2, the ''O'' player, tries to win by the rules of');
  writeln('tic-tac-toe in the yellow (bottom right) part of the board.');
  writeln('Have fun!');
  halt(0);
end;

temp := '1234QWERASDFZXCV';
for i := 1 to 4 do for l := 1 to 4 do b[i,l]:=temp[(l-1)*4+i];
for i := 1 to 2 do control[i]:=false;
s[1] := 'X'; s[2] := 'O';

plotb(xb,yb);
initplayers;

for i := 1 to 4 do for l := 1 to 4 do b[i,l]:=' ';
plotb(xb,yb);

abort := false; turn := 2;
repeat
turn := 3-turn;
checkfull;
if control[turn] then cpumove(turn) else playermove(turn);
plotb(xb,yb);
until abort;
end.