Program
Kurs_check;
Uses
Graph,Crt;
Type
Position = record
x,y : integer;
end;
ChessType = (W,WD,B,BD,N,G);
DeskType = array[-3..14,-3..14] of ChessType;
TPlayer = object
Start,Finish : Position;
Color : boolean;{.t. если белые}
Fight : boolean;{.t. если нужно бить}
loose : boolean;{.t. если проиграл}
procedure Init (_Color : Boolean);
end;
TDesk = object
Desk : DeskType;
sx,sy : word;
procedure Init;
procedure Draw;
procedure DrawFigure(x,y:Word;f:ChessType);
function NoStep (Player:TPlayer):boolean;
function NoStep2 (Player:TPlayer):boolean;
function MoveFrom (Player:TPlayer):boolean;
function MoveFrom2 (Player:TPlayer):boolean;
function NoFight (Player:TPlayer):boolean;
function NoFight2 (Player:TPlayer):boolean;
function can_move (Player:TPlayer):boolean;
function can_move2 (Player:TPlayer):boolean;
function must_fight (Player:TPlayer):boolean;
function must_fight2 (Player:TPlayer):boolean;
function Analise (var Player:TPlayer):boolean;
procedure ScanDamk;
end;
TGame = object
Desk : TDesk;
GameOver : boolean;
procedure Init;
procedure Run;
procedure Play (var Player : TPlayer);
end;
const sx=45;
DeskInit : DeskType = ((G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G),
(G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G),
(G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G),
(G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G),
(G,G,G,G,N,W,N,W,N,W,N,W,N,W,G,G,G,G),
(G,G,G,G,W,N,W,N,W,N,W,N,W,N,G,G,G,G),
(G,G,G,G,N,W,N,W,N,W,N,W,N,W,G,G,G,G),
(G,G,G,G,W,N,W,N,W,N,W,N,W,N,G,G,G,G),
(G,G,G,G,N,N,N,N,N,N,N,N,N,N,G,G,G,G),
(G,G,G,G,N,N,N,N,N,N,N,N,N,N,G,G,G,G),
(G,G,G,G,N,B,N,B,N,B,N,B,N,B,G,G,G,G),
(G,G,G,G,B,N,B,N,B,N,B,N,B,N,G,G,G,G),
(G,G,G,G,N,B,N,B,N,B,N,B,N,B,G,G,G,G),
(G,G,G,G,B,N,B,N,B,N,B,N,B,N,G,G,G,G),
(G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G),
(G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G),
(G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G),
(G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G,G));
Var Game : TGame;
Player1: TPlayer;
Player2: TPlayer;
ii,jj:integer;
kto : byte;
Checks:array[chesstype]of byte;
procedure Beep;
{пищит}
begin
{write(#7);}
end;
procedure TGame.Init;
{инициализация графики}
var
Gd,Gm,GR : Integer;
begin
Gd := 0;
Gm := 0;
InitGraph(Gd,Gm,'');
GR:=GraphResult;
if GR<> 0
then begin
writeln('Ошибка инициализации графики');
halt(0);
end;
GameOver := False;
Desk.Init;
end;
procedure TDesk.Init;
{установка размера игрового поля и всех графических объектов кроме текста}
begin
Desk:=DeskInit;
sx := 45;
end;
procedure TGame.Run;
{выдача сообщений, инициализация игроков и запуск др. модулей}
begin
Desk.Draw;
Player1.Init(True);
Player2.Init(False);
repeat
Desk.DrawFigure(30,30,W);
if Desk.NoStep(Player1)
then
begin
Player1.loose:=True;
GameOver := True;
end;
play(player1);
Desk.DrawFigure(30,30,B);
readkey; if readkey='e' then exit;
if Desk.NoStep2(Player2)
then
begin
Player2.loose:=True;
GameOver := True;
end;
play(player2);
readkey; if readkey='e' then exit;
until GameOver;
end;
function TDesk.NoStep;
{возвращает .T. если у игрока (Color=.t. - W; Color=.f. - B) нет ходов}
var
p : Position;
f : boolean;
begin
p := Player.Start;
f := False;
with Player.Start do
for y:=1 to 10 do
for x:=1 to 10 do
f := f or can_move(Player) or must_fight(player);
Player.Start := p;
NoStep := not f;
end;
function TDesk.NoStep2;
{возвращает .T. если у игрока (Color=.t. - W; Color=.f. - B) нет ходов}
var
p : Position;
f : boolean;
begin
p := Player.Start;
f := False;
with Player.Start do
for y:=1 to 10 do
for x:=1 to 10 do
f := f or can_move2(Player) or must_fight2(player); {nb}
Player.Start := p;
NoStep2 := not f;
end;
procedure TDesk.Draw;{рисует доску и фигуры по данным массива фигур}
var
i,j : byte;
f : boolean;
ax,ay : word;
dx,dy : word;
begin
f:=True;
GetAspectRatio(ax,ay);
SetWriteMode(CopyPut);
SetLineStyle(0,0,1);
sy := round(sx/ay*ax);
dx := GetMaxX div 2 - 5 * sx;
dy := GetMaxY div 2 - 5 * sy;
SetWriteMode(CopyPut);
for j:=0 to 9 do
begin
for i:=0 to 9 do
begin
if f then SetFillStyle(1,15)
else SetFillStyle(1,22);
bar(i*sx+dx,j*sy+dy,(i+1)*sx+dx,(j+1)*sy+dy);
DrawFigure(i*sx+dx+sx div 2,j*sy+dy+sy div 2,Desk[j+1][i+1]);
f:= not f;
end;
f := not f;
end;
end;
procedure TDesk.DrawFigure;
{рисует шашаку используя передаваемые координаты и параметры -
- цвет, дамка/не дамка}
var
rx,ry : word;
begin
rx := 2 * sx div 5;
ry := 2 * sy div 5;
SetWriteMode(CopyPut);
SetLineStyle(0,0,1);
case f of
W,WD : begin
SetFillStyle(1,15);
SetColor(15);
end;
B,BD : begin
SetFillStyle(1,0);
SetColor(0);
end;
end;
case f of
W,B : begin
FillEllipse(x,y,rx,ry);
SetColor(7);
Arc(x,y,45,225,rx+1);
Arc(x,y,45,225,2 * rx div 3 + 1);
Arc(x,y,45,225,rx div 3 + 1);
Arc(x,y,225,45,rx-1);
Arc(x,y,225,45,2 * rx div 3 - 1);
Arc(x,y,225,45,rx div 3 - 1);
SetColor(8);
Arc(x,y,45,225,rx-1);
Arc(x,y,45,225,2 * rx div 3 - 1);
Arc(x,y,45,225,rx div 3 - 1);
Arc(x,y,225,45,rx+1);
Arc(x,y,225,45,2 * rx div 3 + 1);
Arc(x,y,225,45,rx div 3 + 1);
end;
WD,BD : begin
FillEllipse(x,y,rx,ry);
SetColor(7);
Arc(x,y,45,225,rx+1);
Arc(x,y,225,45,rx-2);
SetColor(8);
Arc(x,y,45,225,rx-2);
Arc(x,y,225,45,rx+1);
end;
end;
end;
procedure TPlayer.Init;{инициализация игроков}
begin
loose := False;
Fight:=False;
Color:=_Color; {передается как параметр (T/F)}
if Color
then
begin
Start.x:=5; {нач установка курсора}
Start.y:=4;
end
else
begin
Start.x:=6;
Start.y:=7;
end
end;
procedure TGame.Play;
{основная процедура игры. Осуществляет координацию модулей и движение курсора
выполняется когда ход принадлежит человеку}
procedure Select (p:position);{рисует курсор по передаваемым координатам}
var
dx,dy : word;
begin
SetWriteMode(XorPut);
SetLineStyle(0,0,3);
SetColor(15);
with p, Desk do
begin
x:=x-1;y:=y-1;
dx := GetMaxX div 2 - 5 * sx;
dy := GetMaxY div 2 - 5 * sy;
Graph.MoveTo(x*sx+dx,y*sy+dy);
LineTo((x+1)*sx+dx,y*sy+dy);
LineTo((x+1)*sx+dx,(y+1)*sy+dy);
LineTo(x*sx+dx,(y+1)*sy+dy);
LineTo(x*sx+dx,y*sy+dy);
end;
end;
procedure Select1 (p:position);{рисует курсор по передаваемым координатам}
var
dx,dy : word;
begin
SetWriteMode(CopyPut);
SetLineStyle(0,0,3);
SetColor(3);
with p, Desk do
begin
x:=x-1;y:=y-1;
dx := GetMaxX div 2 - 5 * sx;
dy := GetMaxY div 2 - 5 * sy;
Graph.MoveTo(x*sx+dx,y*sy+dy);
LineTo((x+1)*sx+dx,y*sy+dy);
LineTo((x+1)*sx+dx,(y+1)*sy+dy);
LineTo(x*sx+dx,(y+1)*sy+dy);
LineTo(x*sx+dx,y*sy+dy);
end;
end;
const
SelectStart = 1;
SelectNext = 2;
var
State : byte;
P,Q : Position;
D : DeskType;
F : Boolean;
begin
{ if GameOver then exit;}
with Player, Desk, P do
begin
P:=Start;
D := Desk;
F := Fight;
Q := P;
State := SelectStart;
Select(P); {нарисовали курсор}
repeat
if keypressed
then
case readkey of
#0 : begin {обработка стрелок - перемещение курсора}
Select(P); {стерли курсор}
case readkey of
'K' : x:=x-1;
'M' : x:=x+1;
'H' : y:=y-1;
'P' : y:=y+1;
end;
if x<1 then x:=10;
if y<1 then y:=10;
if x>10 then x:=1;
if y>10 then y:=1;
Select(P); {нарисовали новый}
end;
' ', #13 : case State of
SelectStart : begin
if Color then
begin
Start := P;
if MoveFrom (Player)
then
begin
Fight:=False;
State:=SelectNext;
Select1(P);
Q:=P
end
else Beep;
end
else
begin
Start := P;
{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!проблема!!!!!!} if MoveFrom2 (Player)
then
begin
Fight:=False;
State:=SelectNext;
Select1(P);
Q:=P
end
else Beep;
end;
end;
SelectNext : begin
Finish := P;
if Color then
begin
if Analise (Player)
then
if Fight
then
begin
Start := Finish;
if must_fight(Player)
then Select(P)
else break
end
else break
else Beep;
end else
begin
if Analise (Player)
then
if Fight
then
begin
Start := Finish;
if must_fight2(Player)
then Select(P)
else break
end
else break
else Beep;
end;
end;
end;
'Q','q' : begin
State := SelectStart;
Fight := F;
Desk := D;
P := Q;
Draw;
Select(P);
end;
#27 : begin
GameOver := True;
break;
end;
end;
until False;
Fight := False;
ScanDamk;{count; nowin; }
end;
end;
function TDesk.MoveFrom;{проверяет возможность хода из данной клетки}
begin
if NoFight(Player) then MoveFrom := can_move(Player)
else MoveFrom := must_fight(Player)
end;
function TDesk.MoveFrom2;{проверяет возможность хода из данной клетки}
begin
if NoFight2(Player) then
MoveFrom2 := can_move2(Player)
else
MoveFrom2 := must_fight2(Player)
end;
function TDesk.NoFight;
{возвращает .t. если бить нечего}
var
f : boolean;
begin
f := False;
with Player.Start do
for y:=1 to 10 do
for x:=1 to 10 do
f := f or must_fight(Player);
NoFight := not f;
end;
function TDesk.NoFight2;
{возвращает .t. если бить нечего}
var
f : boolean;
begin
f := False;
with Player.Start do
for y:=1 to 10 do
for x:=1 to 10 do
f := f or must_fight2(Player);
NoFight2 := not f;
end;
function TDesk.can_move;
{возвращает .t. если в текущей клетке есть шашка и ею можно походить}
var
f : boolean;
begin
with Player, Start do
if Color
then
case Desk[y][x] of
W : f := (Desk[y+1][x+1] = N) or (Desk[y+1][x-1] = N);
WD : f := (Desk[y+1][x+1] = N) or (Desk[y+1][x-1] = N) or
(Desk[y-1][x+1] = N) or (Desk[y-1][x-1] = N)
else f := False
end;
can_move := f;
end;
function TDesk.can_move2;
{возвращает .t. если в текущей клетке есть шашка и ею можно походить}
var
f : boolean;
begin
with Player.Start do
case Desk[y][x] of
B : f := (Desk[y-1][x+1] = N) or (Desk[y-1][x-1] = N);
BD : f := (Desk[y+1][x+1] = N) or (Desk[y+1][x-1] = N) or
(Desk[y-1][x+1] = N) or (Desk[y-1][x-1] = N)
else f := False
end;
can_move2 := f;
end;
function TDesk.must_fight;
{возвращает .t. если в текущей позиции есть фишка и она должна что - то бить}
var
f : boolean;
i : integer;
begin
with Player, Start do
if Color
then
case Desk[y][x] of
W : f := ((Desk[y+2][x+2] = N) and (Desk[y+1][x+1] in [B,BD])) or
((Desk[y+2][x-2] = N) and (Desk[y+1][x-1] in [B,BD])) or
((Desk[y-2][x-2] = N) and (Desk[y-1][x-1] in [B,BD])) or
((Desk[y-2][x+2] = N) and (Desk[y-1][x+1] in [B,BD]));
WD : begin
i:=1;
while Desk[y+i][x+i] = N do inc (i);
{ищем ближайшую шашку в этом направлении}
f:=(Desk[y+i][x+i] in [B,BD]) and (Desk[y+i+1][x+i+1] = N);
{если эта шашка черных и за ней нет ничего - надо бить (f=.t.)}
i:=1;
while Desk[y-i][x+i] = N do inc (i);
f:=f or (Desk[y-i][x+i] in [B,BD]) and (Desk[y-i-1][x+i+1] = N);
i:=1;
while Desk[y-i][x-i] = N do inc(i);
f:=f or (Desk[y-i][x-i] in [B,BD]) and (Desk[y-i-1][x-i-1] = N);
i:=1;
while Desk[y+i][x-i] = N do inc(i);
f:=f or (Desk[y+i][x-i] in [B,BD]) and (Desk[y+i+1][x-i-1] = N);
end;
else f:= False;
end;
must_fight := f;
end;
function TDesk.must_fight2;
{возвращает .t. если в текущей позиции есть фишка и она должна что - то бить}
var
f : boolean;
i : integer;
begin
with Player, Start do
case Desk[y][x] of
B : f := ((Desk[y+2][x+2] = N) and (Desk[y+1][x+1] in [W,WD])) or
((Desk[y+2][x-2] = N) and (Desk[y+1][x-1] in [W,WD])) or
((Desk[y-2][x-2] = N) and (Desk[y-1][x-1] in [W,WD])) or
((Desk[y-2][x+2] = N) and (Desk[y-1][x+1] in [W,WD]));
BD : begin
i:=1;
while Desk[y+i][x+i] = N do inc (i);
f:=(Desk[y+i][x+i] in [W,WD]) and (Desk[y+i+1][x+i+1] = N);
i:=1;
while Desk[y-i][x+i] = N do inc (i);
f:=f or (Desk[y-i][x+i] in [W,WD]) and (Desk[y-i-1][x+i+1] = N);
i:=1;
while Desk[y-i][x-i] = N do inc(i);
f:=f or (Desk[y-i][x-i] in [W,WD]) and (Desk[y-i-1][x-i-1] = N);
i:=1;
while Desk[y+i][x-i] = N do inc(i);
f:=f or (Desk[y+i][x-i] in [W,WD]) and (Desk[y+i+1][x-i-1] = N);
end
else f := False
end;
must_fight2 := f;
end;
function TDesk.Analise;
{возвращает .f. если введенный ход не соответствует правилам игры
использует нач. и кон. коорд. положения курсора, а так же
расположение шашек на доске}
var
f,f_ : boolean;
dx,dy,ix,iy,x,y,cw,cb : Integer;
begin
with Player do
if Color
then
begin
case Desk[Start.y][Start.x] of
W : begin
if Fight then f := False else
f := (Finish.y-Start.y=1) and
(abs(Finish.x-Start.x)=1) and
(Desk[Finish.y][Finish.x] = N);
x := (Start.x+Finish.x) div 2;
y := (Start.y+Finish.y) div 2;
Fight := (abs(Finish.y-Start.y)=2) and
(abs(Finish.x-Start.x)=2) and
(Desk[Finish.y][Finish.x]=N) and
(Desk[y][x] in [B,BD]);
end;
WD : begin
if Finish.x>Start.x then dx := 1
else dx := -1;
if Finish.y>Start.y then dy := 1
else dy := -1;
ix:=Start.x+dx;
iy:=Start.y+dy;
f_ := (abs(Finish.x-Start.x) = abs(Finish.y-Start.y)) and
(Desk[Finish.y][Finish.x]=N);
cw:=0;
cb:=0;
if f_ then repeat
if Desk[iy][ix] in [W,WD] then inc(cw);
if Desk[iy][ix] in [B,BD]
then
begin
inc(cb);
x:=ix;
y:=iy;
end;
if (ix=Finish.x) or (iy=Finish.y) then break;
ix :=ix + dx;
iy :=iy + dy;
until (ix=Finish.x) or (iy=Finish.y);
if Fight then f := false
else f := (cb=0) and (cw=0) and f_;
Fight := (cb=1) and (cw=0) and f_;
end
else f := False
end;
if f or Fight
then begin
Desk[Finish.y][Finish.x]:=Desk[Start.y][Start.x];
Desk[Start.y][Start.x] := N;
if (Finish.y = 10)
then Desk[Finish.y][Finish.x]:=WD;
if Fight then Desk[y][x]:=N;
Draw;
end
end
else
begin
case Desk[Start.y][Start.x] of
B : begin
if Fight then f := False else
f := (Start.y-Finish.y=1) and
(abs(Finish.x-Start.x)=1) and
(Desk[Finish.y][Finish.x] = N);
x := (Start.x+Finish.x) div 2;
y := (Start.y+Finish.y) div 2;
Fight := (abs(Finish.y-Start.y)=2) and
(abs(Finish.x-Start.x)=2) and
(Desk[Finish.y][Finish.x]=N) and
(Desk[y][x] in [W,WD]);
end;
BD : begin
if Finish.x>Start.x then dx := 1
else dx := -1;
if Finish.y>Start.y then dy := 1
else dy := -1;
ix:=Start.x+dx;
iy:=Start.y+dy;
f_ := (abs(Finish.x-Start.x) = abs(Finish.y-Start.y)) and
(Desk[Finish.y][Finish.x]=N);
cw:=0;
cb:=0;
if f_ then repeat
if Desk[iy][ix] in [B,BD] then inc(cb);
if Desk[iy][ix] in [W,WD]
then
begin
inc(cw);
x:=ix;
y:=iy;
end;
if (ix=Finish.x) or (iy=Finish.y) then break;
ix :=ix + dx;
iy :=iy + dy;
until (ix=Finish.x) or (iy=Finish.y);
if Fight then f := false
else f:= (cb=0) and (cw=0) and f_;
Fight := (cw=1) and (cb=0) and f_;
end
else f := False
end;
if f or Fight
then begin
Desk[Finish.y][Finish.x]:=Desk[Start.y][Start.x];
Desk[Start.y][Start.x] := N;
if (Finish.y = 1)
then Desk[Finish.y][Finish.x]:=BD;
if Fight then Desk[y][x]:=N;
Draw;
end;
end;
Analise := f or Player.Fight;
end;
procedure Tdesk.ScanDamk;
{превращает шашку в дамку если она достигла нужной позиции}
var
i : byte;
begin
for i := 1 to 10 do
begin
if Desk[1,i] = B then Desk[1,i] := BD;
if Desk[10,i] = W then Desk[10,i] := WD;
end;
end;
BEGIN
Game.Init;
Game.Run;
END.