sem1234

uses
ABCObjects, GraphABC;

var
pole: array [,] of ObjectABC;
hod: char := 'X';
ok: ObjectABC;
test:integer;
const
vin = 5;

procedure picture(n, m: integer);
var
i, j: integer;
begin
for i := 0 to m - 1 do
for j := 0 to n - 1 do
if pole[i, j] = nil then
pole[i, j] := new SquareABC(i * 30 + 40, j * 30 + 40, 30, clwhite);
end;

function vert(j: integer): boolean;
var
kz: integer;//
i: integer;
phod: char;
begin
if hod = 'X' then phod := 'O'
else phod := 'X';
for i := 0 to length(pole, 0) - 1 do
if pole[i, j].Text = phod then // подсчет строк
begin
inc(kz);
if kz = 5 then begin
result := true;
exit; end;
end
else
kz := 0;
end;

function gor(i: integer): boolean;
var
kz: integer;
j: integer;
phod: char;
begin
if hod = 'X' then phod := 'O'
else phod := 'X';
for j := 0 to length(pole, 1) - 1 do
if pole[i, j].Text = phod then // подсчет строк
begin
inc(kz);
if kz = 5 then begin
result := true;
exit; end;
end
else
kz := 0;
end;

function dig(i, j: integer): boolean;
var
kz: integer;
phod: char;
x := i;
y := j;
begin
if hod = 'X' then phod := 'O'
else phod := 'X';
while (x > 0) and (y > 0) do
begin
dec(x);
dec(y);
end;
while (x <= length(pole, 0) - 1) and (y <= length(pole, 1) - 1) do
begin
if pole[x, y].Text = phod then // подсчет строк
begin
inc(kz);
if kz = 5 then begin
result := true;
exit; end;
end
else
kz := 0;
inc(x);
inc(y);
end;
x := i;
y := j;
while (x > 0) and (y < length(pole, 1) - 1) do
begin
dec(x);
inc(y);
end;
kz:=0;
while (x <= length(pole, 0) - 1) and (y > 0) do
begin
if pole[x, y].Text = phod then // подсчет строк
begin
inc(kz);
if kz = 5 then begin
result := true;
exit; end;
end
else
kz := 0;
inc(x);
dec(y);
end;
end;

function proverka(i, j: integer): boolean;
var
x, y: integer;
begin

if vert(j) or gor(i) or dig(i, j) then
begin result := true; exit; end;
if i = length(pole, 0) - 1 then
begin
setlength(pole, length(pole, 0) + 1, length(pole, 1));
picture(length(pole, 1), length(pole, 0 ));
end;
if j = length(pole, 1) - 1 then
begin
setlength(pole, length(pole, 0), length(pole, 1) + 1);
picture(length(pole, 1), length(pole, 0 ));
end;
if i = 0 then
begin
setlength(pole, length(pole, 0) + 1, length(pole, 1));
for x := length(pole, 0) - 2 downto 0 do
for y := length(pole, 1) - 1 downto 0 do
begin
pole[x, y].Left := pole[x, y].Left + 30;
pole[x + 1, y] := pole[x, y];
pole[x, y] := nil;
end;
picture(length(pole, 1), length(pole, 0 ));
end;
if j = 0 then
begin
setlength(pole, length(pole, 0), length(pole, 1) + 1);
for y := length(pole, 1) - 2 downto 0 do
for x := length(pole, 0) - 1 downto 0 do
begin
pole[x, y].top := pole[x, y].top + 30;
pole[x, y + 1] := pole[x, y];
pole[x, y] := nil;
end;
picture(length(pole, 1), length(pole, 0 ));
end;
result := false;
end;

procedure rest;
var
n, m: integer;
begin
readln(n, m);
pole := new ObjectABC[n, m];
setlength(pole, n, m);
picture(m, n);
end;

procedure MyMouseDown(x, y, mb: integer);
var
ob: ObjectABC;
i, j: integer;
begin
ob := ObjectUnderPoint(x, y);
if ok = nil then
begin
if ob <> nil then
if ob.text = '' then
if hod = 'X' then begin ob.text := 'X'; hod := 'O'; end
else begin ob.text := 'O'; hod := 'X'; end;
if ob <> nil then
if ob.Text <> '' then
for i := 0 to Length(pole, 0) - 1 do
for j := 0 to Length(pole, 1) - 1 do
if pole[i, j].PtInside(x, y) then
begin
if proverka(i, j) then
begin
{ if hod = 'O' then window.Title := 'Выйграли крестики'
else window.Title := 'Выйграли нолики'; }
ok := new SquareABC(window.Width div 2 - 50, window.Height div 2 - 50, 100, clwhite);
if hod = 'O' then ok.Text := 'Выйграли крестики'
else ok.Text := 'Выйграли нолики';
end;
end;
end;
{ if ob = ok then
begin ok.Destroy;rest;end;}
end;

begin
rest;
OnMouseDown := MyMouseDown;
end.

Vladimir_S

Поскольку, в соответствии с п.2.5 Правил, языком форума является русский, а этой смесью олбанского с зулусским у нас никто не владеет, тему я закрываю.

AlexZir

Комментирую полностью листинг - дана программа, реализующая игру крестики-нолики средствами языка программирования PascalABC.
За более подробными комментариями обратитесь к разработчику листинга.