uses crt, graph;

Procedure DrawTable;
  Var
    i, DX, DY: Integer;
  Begin
    DX := GetMaxX Div 5;
    DY := GetMaxY Div 5;

    For i := 1 To 4 Do
      Line(DX, i*DY, 4*DX, i*DY);
    For i := 1 To 4 Do
      Line(i*DX, DY, i*DX, 4*DY);
  End;

const
  colors: array[boolean] Of integer =
    (red, white);


Procedure PutChar(b: boolean; x, y: Integer; Ch: Char);
  var centerx, centery: integer;
  begin
    centerx := x*(getmaxx Div 5) + (getmaxx div 10);
    centery := y*(getmaxy Div 5) + (getmaxy div 10);

    setcolor(colors[b]);
    settextjustify(centertext, centertext);
    outtextxy(centerx, centery, ch);
    setcolor(white);
  end;

var
  tbl: array[1 .. 3, 1 .. 3] of integer;

function sumDiag(main: Boolean): Integer;
  var i, s: integer;
  begin
    s := 0;
    case main of
      false:
        for i := 1 to 3 do
          s := s + tbl[i, i];
      true:
        for i := 1 to 3 do
          s := s + tbl[i, 3 - i + 1]
    end;
    sumDiag := s
  end;

function sumR(x: integer): integer;
  var i, s: integer;
  begin
    s := 0;
    for i := 1 to 3 do
      s := s + tbl[x, i];
    sumR := s
  end;

function sumC(x: integer): integer;
  var i, s: integer;
  begin
    s := 0;
    for i := 1 to 3 do
      s := s + tbl[i, x];
    sumC := s
  end;

var
  grDriver: Integer;
  grMode: Integer;
  ErrCode: Integer;

const
  prompt: array[boolean] Of String =
    ('Player 2 >', 'Player 1 >');
  letter: array[boolean] Of Char =
    ('0', 'X');
  amount: array[boolean] Of Byte =
    (7, 10);
  possibleLetters: set of char = ['1' .. '9'];
var
  imove, p: Integer;
  posX, posY: integer;
  curr, ch: char;
  i, j: integer;
  winner, ok, b, stopped: boolean;

begin
  grDriver := Detect;
  InitGraph(grDriver, grMode,'');
  ErrCode := GraphResult;
  if ErrCode <> grOk then
  begin
    Writeln('Graphics error:', GraphErrorMsg(ErrCode)); halt(100)
  end;

  for i := 1 to 3 do
    for j := 1 to 3 do
      tbl[i, j] := 0;

  DrawTable;
  For imove := 1 to 9 do
    begin
      setviewport(1, getmaxy-60, getmaxx, getmaxy, true);
      clearviewport;
      setviewport(1, 1, getmaxx, getmaxy, true);

      outtextxy(getmaxx div 2, getmaxy - 30, prompt[odd(imove)]);
      repeat
        ch := readkey;
      until ch in possibleletters;
      possibleletters := possibleletters - [ch];
      p := Ord(ch) - Ord('0');

      posY := ((p - 1) div 3) + 1;
      posX := (p mod 3);
      if posX = 0 then posX := 3;
      PutChar(odd(imove), posX, posY, letter[odd(imove)]);

      tbl[posX, posY] := amount[odd(imove)];

      stopped := false;
      for b := false to true do
        begin
          for i := 1 to 3 do
            if (sumR(i) = 3*amount[b]) or
               (sumC(i) = 3*amount[b]) then
              begin
                winner := b; stopped := true;
              end;

          if not stopped then
            if (sumDiag(false) = 3*amount[b]) or
               (sumDiag(true) = 3*amount[b]) then
              begin
                  winner := b; stopped := true;
              end;
        end;

      if stopped then break;
    end;

  setviewport(1, getmaxy-60, getmaxx, getmaxy, true);
  clearviewport;
  setviewport(1, 1, getmaxx, getmaxy, true);

  if stopped then
    begin
      setcolor(red);
      outtextxy(getmaxx div 2, getmaxy - 30,
                'Winner: ' + prompt[winner]);
      setcolor(white); readln
    end
  else
    begin
      setcolor(lightblue);
      outtextxy(getmaxx div 2, getmaxy - 30,
                'no winner...');
      setcolor(white); readln
    end;

  CloseGraph
end.