unit
Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, Menus, XPMan;
type
TForm1 =
class
(TForm)
Image1: TImage;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
XPManifest1: TXPManifest;
procedure
FormCreate(Sender: TObject);
procedure
FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y:
Integer
);
procedure
N1Click(Sender: TObject);
procedure
N2Click(Sender: TObject);
private
public
end
;
const
C_CellWH =
60
;
C_CC =
5
;
type
TKrestikNolik = (knKrestik,knNolik);
TGorVertDiag = (gvGor,gvVert,gvD1,gvD2,gvAll);
TPole =
array
[
0..
C_CC-
1
]
of
array
[
0..
C_CC-
1
]
of
Byte
;
var
Form1: TForm1;
Pl: TPole;
procedure
PaintKN(S:TKrestikNolik; CellX,CellY:
byte
);
function
isYes(
var
P:TPole):
byte
;
function
RandomNolik(
var
P:TPole; N:TGorVertDiag; K:
byte
):
Boolean
;
function
NewNolik(
var
P:TPole; prevX,prevY:
byte
):
byte
;
procedure
NewGame;
implementation
{$R *.dfm}
procedure
PaintKN(S:TKrestikNolik; CellX,CellY:
byte
);
begin
Form1
.
Image1
.
Canvas
.
Pen
.
Width:=
8
;
Case
S
of
knKrestik:
begin
Form1
.
Image1
.
Canvas
.
Pen
.
Color:=clRed;
Form1
.
Image1
.
Canvas
.
MoveTo( (C_CellWH
div
8
) + CellX*C_CellWH,
(C_CellWH
div
8
) + CellY*C_CellWH );
Form1
.
Image1
.
Canvas
.
LineTo(
7
*(C_CellWH
div
8
) + CellX*C_CellWH,
7
*(C_CellWH
div
8
) + CellY*C_CellWH );
Form1
.
Image1
.
Canvas
.
MoveTo( (C_CellWH
div
8
) + CellX*C_CellWH,
7
*(C_CellWH
div
8
) + CellY*C_CellWH );
Form1
.
Image1
.
Canvas
.
LineTo(
7
*(C_CellWH
div
8
) + CellX*C_CellWH,
(C_CellWH
div
8
) + CellY*C_CellWH );
end
;
knNolik:
begin
Form1
.
Image1
.
Canvas
.
Pen
.
Color:=clBlue;
Form1
.
Image1
.
Canvas
.
Brush
.
Style:=bsClear;
Form1
.
Image1
.
Canvas
.
Ellipse( (C_CellWH
div
8
) + CellX*C_CellWH,
(C_CellWH
div
8
) + CellY*C_CellWH,
7
*(C_CellWH
div
8
) + CellX*C_CellWH,
7
*(C_CellWH
div
8
) + CellY*C_CellWH );
end
;
End
;
end
;
function
isYes(
var
P:TPole):
byte
;
var
i,j:
byte
; A:
Boolean
; k,n:
byte
;
begin
k:=
0
; n:=
0
;
for
i:=
0
to
C_CC-
1
do
if
p[i,i] =
1
then
Inc(k)
else
if
p[i,i] =
2
then
Inc(n);
if
k = C_CC
then
begin
Result:=
1
; Exit;
end
;
if
n = C_CC
then
begin
Result:=
2
; Exit;
end
;
k:=
0
; n:=
0
;
for
i:=
0
to
C_CC-
1
do
if
p[i,C_CC-
1
-i] =
1
then
Inc(k)
else
if
p[i,C_CC-
1
-i] =
2
then
Inc(n);
if
k = C_CC
then
begin
Result:=
1
; Exit;
end
;
if
n = C_CC
then
begin
Result:=
2
; Exit;
end
;
for
i:=
0
to
C_CC-
1
do
begin
k:=
0
; n:=
0
;
for
j:=
0
to
C_CC-
1
do
if
p[i,j] =
1
then
Inc(k)
else
if
p[i,j] =
2
then
Inc(n);
if
k = C_CC
then
begin
Result:=
1
; Exit;
end
;
if
n = C_CC
then
begin
Result:=
2
; Exit;
end
;
k:=
0
; n:=
0
;
for
j:=
0
to
C_CC-
1
do
if
p[j,i] =
1
then
Inc(k)
else
if
p[j,i] =
2
then
Inc(n);
if
k = C_CC
then
begin
Result:=
1
; Exit;
end
;
if
n = C_CC
then
begin
Result:=
2
; Exit;
end
;
end
;
A:=
false
;
for
i:=
0
to
C_CC-
1
do
begin
for
j:=
0
to
C_CC-
1
do
if
P[i,j] =
0
then
begin
A:=
true
; Break;
end
;
if
A
then
Break;
end
;
if
not
A
then
begin
Result:=
3
; Exit;
end
;
Result:=
0
;
end
;
function
RandomNolik(
var
P:TPole; N:TGorVertDiag; K:
byte
):
Boolean
;
var
i,j:
byte
;
begin
Result:=
False
;
if
N = gvAll
then
begin
if
P[
0
,
0
] =
0
then
begin
P[
0
,
0
]:=
2
;
PaintKN(knNolik,
0
,
0
);
Result:=
True
; Exit;
end
;
if
P[C_CC-
1
,C_CC-
1
] =
0
then
begin
P[C_CC-
1
,C_CC-
1
]:=
2
;
PaintKN(knNolik,C_CC-
1
,C_CC-
1
);
Result:=
True
; Exit;
end
;
if
P[
0
,C_CC-
1
] =
0
then
begin
P[
0
,C_CC-
1
]:=
2
;
PaintKN(knNolik,
0
,C_CC-
1
);
Result:=
True
; Exit;
end
;
if
P[C_CC-
1
,
0
] =
0
then
begin
P[C_CC-
1
,
0
]:=
2
;
PaintKN(knNolik,C_CC-
1
,
0
);
Result:=
True
; Exit;
end
;
for
i:=
0
to
C_CC-
1
do
for
j:=
0
to
C_CC-
1
do
if
P[i,j] =
0
then
begin
P[i,j]:=
2
;
PaintKN(knNolik,i,j);
Result:=
True
; Exit;
end
;
end
;
for
i:=
0
to
C_CC-
1
do
begin
Case
N
of
gvGor:
begin
if
P[i,K] =
0
then
begin
P[i,K] :=
2
;
PaintKN(knNolik,i,K);
Result:=
True
;
Exit;
end
else
Result:=
False
;
end
;
gvVert:
begin
if
P[K,i] =
0
then
begin
P[K,i] :=
2
;
PaintKN(knNolik,K,i);
Result:=
True
;
Exit;
end
else
Result:=
False
;
end
;
gvD1:
begin
if
P[i,i] =
0
then
begin
P[i,i] :=
2
;
PaintKN(knNolik,i,i);
Result:=
True
;
Exit;
end
else
Result:=
False
;
end
;
gvD2:
begin
if
P[i,C_CC-
1
-i] =
0
then
begin
P[i,C_CC-
1
-i] :=
2
;
PaintKN(knNolik,i,C_CC-
1
-i);
Result:=
True
;
Exit;
end
else
Result:=
False
;
end
;
End
;
end
;
end
;
function
NewNolik(
var
P:TPole; prevX,prevY:
byte
):
byte
;
var
i,j,n:
byte
; KG,KV,KD1,KD2,NG,NV,ND1,ND2,RN:
Boolean
;
vinX,vinY:
byte
;
begin
Result:=
0
;
i:=isYes(P);
if
i
in
[
1
,
3
]
then
begin
Result:=i; Exit;
end
;
KG:=
False
; KV:=
False
; KD1:=
False
; KD2:=
False
;
NG:=
False
; NV:=
False
; ND1:=
False
; ND2:=
False
;
RN:=
False
;
for
i:=
0
to
C_CC-
1
do
begin
if
i <> prevX
then
Case
P[i,prevY]
of
1
: KG:=
True
;
2
: NG:=
True
;
end
;
if
i <> prevY
then
Case
P[prevX,i]
of
1
: KV:=
True
;
2
: NV:=
True
;
end
;
end
;
if
prevX = prevY
then
for
i:=
0
to
C_CC-
1
do
if
i <> prevX
then
Case
P[i,i]
of
1
: KD1:=
True
;
2
: ND1:=
True
;
end
;
if
prevX + prevY = C_CC-
1
then
for
i:=
0
to
C_CC-
1
do
if
i <> prevX
then
Case
P[i,C_CC-
1
-i]
of
1
: KD2:=
True
;
2
: ND2:=
True
;
end
;
vinX:=
255
; vinY:=
255
;
for
i:=
0
to
C_CC-
1
do
begin
n:=
0
;
for
j:=
0
to
C_CC-
1
do
if
P[i,j] =
2
then
Inc(n);
if
n = C_CC-
1
then
begin
for
j:=
0
to
C_CC-
1
do
if
P[i,j] =
0
then
begin
VinY:=j; VinX:=i; Break;
end
;
if
(VinX <>
255
)
and
(VinY <>
255
)
then
Break;
end
;
n:=
0
;
for
j:=
0
to
C_CC-
1
do
if
P[j,i] =
2
then
Inc(n);
if
n = C_CC-
1
then
begin
for
j:=
0
to
C_CC-
1
do
if
P[j,i] =
0
then
begin
VinY:=i; VinX:=j; Break;
end
;
if
(VinX <>
255
)
and
(VinY <>
255
)
then
Break;
end
;
end
;
while
True
do
begin
if
(VinX <>
255
)
and
(VinY <>
255
)
then
begin
P[VinX,VinY]:=
2
;
PaintKN(knNolik,VinX,VinY);
RN:=
true
;
end
;
if
RN
then
Break;
if
KG
and
not
NG
then
RN := RandomNolik(P,gvGor,prevY);
if
RN
then
Break;
if
KV
and
not
NV
then
RN := RandomNolik(P,gvVert,prevX);
if
RN
then
Break;
if
KD1
and
not
ND1
then
RN := RandomNolik(P,gvD1,
0
);
if
RN
then
Break;
if
KD2
and
not
ND2
then
RN := RandomNolik(P,gvD2,
0
);
if
RN
then
Break;
RandomNolik(P,gvAll,
0
);
Break;
end
;
i:=isYes(P);
if
i
in
[
2
,
3
]
then
begin
Result:=i; Exit;
end
;
end
;
procedure
NewGame;
var
i:
integer
;
begin
Form1
.
Image1
.
Picture:=
nil
;
Form1
.
Image1
.
Canvas
.
Pen
.
Color:=clBlack;
for
i:=
1
to
C_CC-
1
do
begin
Form1
.
Image1
.
Canvas
.
MoveTo(C_CellWH*i,
0
);
Form1
.
Image1
.
Canvas
.
LineTo(C_CellWH*i,Form1
.
Image1
.
Height);
Form1
.
Image1
.
Canvas
.
MoveTo(
0
,C_CellWH*i);
Form1
.
Image1
.
Canvas
.
LineTo(Form1
.
Image1
.
Width,C_CellWH*i);
end
;
FillChar(Pl,SizeOf(pl),
0
);
end
;
procedure
TForm1
.
FormCreate(Sender: TObject);
var
i:
integer
;
begin
Form1
.
ClientHeight:=C_CellWH*C_CC;
Form1
.
ClientWidth:=Form1
.
ClientHeight;
Image1
.
ClientWidth:=Form1
.
ClientWidth;
Image1
.
ClientHeight:=Image1
.
ClientWidth;
Image1
.
Picture:=
nil
;
Image1
.
Canvas
.
Pen
.
Color:=clBlack;
for
i:=
1
to
C_CC-
1
do
begin
Image1
.
Canvas
.
MoveTo(C_CellWH*i,
0
);
Image1
.
Canvas
.
LineTo(C_CellWH*i,Image1
.
Height);
Image1
.
Canvas
.
MoveTo(
0
,C_CellWH*i);
Image1
.
Canvas
.
LineTo(Image1
.
Width,C_CellWH*i);
end
;
FillChar(Pl,SizeOf(pl),
0
);
end
;
procedure
TForm1
.
FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y:
Integer
);
var
Mess:
String
;
begin
if
Button
in
[mbRight,mbMiddle]
then
Exit;
if
Pl[(X
div
C_CellWH), (Y
div
C_CellWH)] <>
0
then
Exit;
PaintKN(knKrestik,(X
div
C_CellWH), (Y
div
C_CellWH));
Pl[(X
div
C_CellWH),(Y
div
C_CellWH)]:=
1
;
Case
NewNolik(Pl,(X
div
C_CellWH),(Y
div
C_CellWH))
of
0
: Mess:=
''
;
1
: Mess:=
'Крестики выиграли!'
;
2
: Mess:=
'Нолики выиграли!'
;
3
: Mess:=
'Ничья'
;
End
;
if
Mess <>
''
then
Case
MessageDlg(Mess+#
13
#
10
+
'Хотите сыграть ещё раз?'
,mtConfirmation,[mbYes, mbNo, mbCancel],
0
)
of
mrYes: NewGame;
mrNo: Application
.
Terminate;
End
;
end
;
procedure
TForm1
.
N1Click(Sender: TObject);
begin
NewGame;
end
;
procedure
TForm1
.
N2Click(Sender: TObject);
begin
Application
.
Terminate;
end
;
end
.