Программирование / Курсовые / Arcanoid / Arcanoid / ARCAN

uses ArcUnit,ArcUnitK,ArcUnitM,ArcSound,Graph,Crt;

const
TC = 2;
TL = 70;
TH = 20;{h telegi nad MaxY}
BC = 6;
TS = 3;
BR = 3;
BrW = 30;
BrH = 15;
x1 = 40;
x2 = 40;
y1 = 40;
y2 = 40;
n1 = 10;
n2 = 15;

type
TBrick = record
x,y: Integer;
Color: Byte;
Life: Boolean;
end;

var
ButtonC,EC:byte; LB,RB,TB:boolean;
MaxX,MaxY: Integer;
TX, oldTX: Integer;
BX,BY: Integer;
BVx,BVy: Integer;
dPause:real;
xmouse,ymouse:integer;
sc:longint;

label Fin;
{----Score-----}
procedure Score(sc:longint; col:word);
var st:string;
begin
str(sc,st);
SetColor(col);
OutTextXY(x1+5,y1+5,'ЋзЄЁ');
OutTextXY(x1+75,y1+5,st);
end;
procedure ClearScore;
begin
SetfillStyle(1,0); SetColor(0); Bar(x1+1,y1+1,x1+31,y1+6);
end;


{- Bricks -----------------}
var
Brk: array[1..n1,1..n2] of TBrick;
procedure InitBricks;
var i,j: Byte;
K: Integer;
begin
Randomize;
K:=5+Random(20);
for j:=1 to n1 do
for i:=1 to n2 do
with Brk[j,i] do
begin
Color:=4{Random(15)+1};
Life:=True;
x:=i*(BrW+1)+12+x1;
y:=j*(BrH+1)+y1+K;
end;
end;
procedure DrawBricks;
var i,j: Byte;
begin
for j:=1 to n1 do
for i:=1 to n2 do
with Brk[j,i] do
begin
SetFillStyle(1,Random(Color)+2);
Bar(x,y,x+BrW-1,y+BrH-1);
end;
end;
procedure ClB(i,j: Byte);
begin
with Brk[j,i] do
begin
SetFillStyle(1,0);
Bar(x,y,x+BrW-1,y+BrH-1);
Life:=False;
end;
end;
procedure CheckBricks;
var i,j: Byte;
begin
for j:=1 to n1 do
for i:=1 to n2 do
with Brk[j,i] do
if Life then
begin
if (BX+BR>x)and(BX-BR<x+BrW) then
begin
if (BY=y-BR)or(BY=y+BrH+BR) then begin BVy:=-BVy; Score(sc,0); sc:=sc+10;
Score(sc,7); Beep1; ClB(i,j) end;
end else
if (BY+BR>y)and(BY-BR<y+BrH) then
begin
if (BX=x-BR)or(BX=x+BrW+BR) then begin BVx:=-BVx; Score(sc,0); sc:=sc+10;
Score(sc,7); Beep1; ClB(i,j) end;
end;
end;

end;
{--------------------------}
procedure Telega;
begin
if mouse=false then begin
if oldTX>tx then begin
setcolor(TC); moveto(oldTX,MaxY-TH-y2);
LineTo(TX,MaxY-TH-y2); LineTo(TX,MaxY-TH-y2+5);
LineTo(oldTX,MaxY-TH-y2+5);
setcolor(0); LineTo(oldTX,MaxY-TH-y2);
moveto(TX+TL,MaxY-TH-y2);
LineTo(oldTX+TL,MaxY-TH-y2); LineTo(oldTX+TL,MaxY-TH-y2+5);
LineTo(oldTX,MaxY-TH-y2+5);
setcolor(TC); LineTo(oldTX,MaxY-TH-y2);
end;
end;
end;
procedure Ball;
begin
SetWriteMode(1); SetColor(BC);
Rectangle(BX-BR,BY-BR,BX+BR,BY+BR);
Line(BX-BR+1,BY-BR+1,BX+BR-1,BY+BR-1);
Line(BX+BR-1,BY-BR+1,BX-BR+1,BY+BR-1);
Line(BX+(BR div 2)-1,BY-BR+1,BX+(BR div 2)-1,BY+BR-1);
Line(BX+BR-1,BY+(BR div 2)-1,BX-BR+1,BY+(BR div 2)-1);
end;
procedure Pole;
begin
SetColor(1); Rectangle(x1,y1,MaxX-x2,MaxY-y2);
end;
procedure MoveM(s: ShortInt);
begin
GetMouseXY(xmouse,ymouse,LB,RB,TB);
TX:=xmouse;
end;
procedure MoveK(s: ShortInt);
begin
oldTX:=TX;
TX:=TX+s;
end;

procedure CheckRange;
begin
if TX<x1 then TX:=x1;
if TX+TL>MaxX-x2 then TX:=MaxX-TL-x2;
if (BX-BR=x1)or(BX+BR=MaxX-x2) then BVx:=-BVx;
if BY-BR=y1 then BVy:=-BVy;
if (BX+BR>TX)and(BX-BR<TX+TL) then
if BY+BR=MaxY-TH-y2 then begin
BVy:=-BVy; Beep2;
if BX>TX+TL/2 then
BVx:=-Round(1*(cos((BX-TX+TL/2)/(TL/2)))) else
BVx:=-Round(1*(cos((BX-TX)/(TL/2))))
end;
end;
function CheckWin: Boolean;
var i,j: Byte;
W: Boolean;
begin W:=True;
for j:=1 to n1 do for i:=1 to n2 do W:=W and not Brk[j,i].Life;
CheckWin:=W;
end;
function CheckLose: Boolean;
begin
CheckLose:=BY+BR>MaxY-5-y2;
end;
procedure ActiveBall;
begin
BX:=BX+BVx;
BY:=BY+BVy;
end;
procedure InitVars;
begin
TX:=MaxX div 2 - TL div 2;
BX:=TX + TL - BR;
BY:=MaxY - TH - BR - y2;
BVx:=-1; BVy:=-1;
end;

procedure InitGame;
var drv,mode: Integer;
begin drv:=Vga; mode:=2;
InitGraph(drv,mode,'c:\progra~1\borland\tp\bgi');HighVideo;
Init(ButtonC,EC); ClearDevice;
MaxX:=GetMaxX; MaxY:=GetMaxY; dPause:=0.1;
InitVars; InitBricks; DrawBricks;
end;
procedure GameRun;
begin
sc:=0; Pole;
SetColor(TC);{Ќ з «м­®Ґ Ї®«®¦Ґ­ЁҐ ⥫ҐЈЁ}
Rectangle(TX,MaxY-TH-y2,TX+TL,MaxY-TH+5-y2);
Rectangle(TX-2,MaxY-TH-y2+2,TX+TL-2,MaxY-TH+3-y2);
Ball;
repeat
{Telega;} Ball; Score(sc,7);
if Mouse=False then begin
if GetKey(kbRight) then MoveK(TS);
if GetKey(kbLeft) then MoveK(-TS); end;
if Mouse=True then MoveM(TS);
ActiveBall;
CheckRange;
CheckBricks;
if CheckLose then begin InitVars;
SetColor(4); OutTextXY(MaxX div 2-50,250,'TRY AGAIN !'); Delay(3000);
SetColor(0); OutTextXY(MaxX div 2-50,250,'TRY AGAIN !');
end;
if CheckWin then begin ClearDevice; InitVars; InitBricks; DrawBricks; Pole;
end;
Telega; Ball;
dPause:=dPause+0.0001;
Delay(30);
if dPause>20 then dPause:=0;
until GetKey(kbEsc);
end;
procedure DoneGame;
begin
DoneKBD;
CloseGraph;
end;

begin
InitKBD;
Zastavka;
InitGame;
GameRun;
DoneGame;
end.