Программирование / Курсовые / 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.