old/PAS/ARKENOID/ARKENOID.PAS

Uses CRT,Graph,DOS;
Procedure LITTFONT;external;
{$L litt.obj}
Procedure VGADRV;external;
{$L vgadrv.obj}
Procedure SansFont;external;
{$L sans.obj}
Procedure tripFont;external;
{$L trip.obj}

const
 path = '';

Type Block = record
  x,y:Integer;
  style:byte;
End;

Type Hiscore = record
  Name  : array[1..10] of string[13];
  Score : array[1..10] of Word;
end;

Var
  Tbl                          : file of HiScore;
  MAX                          : HiScore;
  rcrd                         : boolean;
  level                        : text;
  numoflev                     : byte;
  Score                        : word;
  MainX,MainY,Beg_of_pad       : Integer;
  BallPos,LastPos              :PointType;
  AddX,AddY,count_of_bricks,NUM:Integer;
  Side                         :boolean;
  blocks                       : array [1..84] of block;
  size                         :word;
  b,p                          :pointer;
  brick                        : array [1..3] of pointer;
  s                            : SearchRec;
{----------------------------------------------------------------------}
Procedure DrawPad;forward;
Procedure DrawBlocks(numlev : byte);forward;
Procedure GamOvr;forward;
{----------------------------------}
Procedure Recrd(i : byte);
Var t : byte;
Begin
  if rcrd then begin
    RestoreCRTMode;
    ClrScr;
    GotoXY(30,10);
    if i = 10 then max.score[10] := score
    else
      for t := 9 downto i do begin
        max.score[t+1] := max.score[t];
        max.name[t+1] := max.name[t]
      end;
    max.score[i] := score;
    TextColor(cyan);
    Write('П О З Д Р А В Л Я Ю');
    GotoXY(30,12);
    TextColor(Blue);
    Write('Вы поставили рекорд');
    GotoXY(12,17);
    TextColor(Yellow);
    Write('Введите свое имя до 13 символов ');
    TextColor(lightgreen);
    Read(max.name[i]);
    Seek(tbl,0);
    Write(tbl,max);
    Close(tbl);
    SetGraphMode(GetGraphMode);
  end;
end;
{-----------------------------------------------------------}
Procedure NextLev;
Var
 nameoflev : string;
Begin
  inc(numoflev);
  Str(numoflev,nameoflev);
  assign(level,concat('level',nameoflev));
  {$I-}
  reset(level);
  if IOResult <> 0 then GamOvr;
  {$I+}
  PutImage(beg_of_pad,460,P^,XORPut);
  PutImage(BallPos.X,BallPos.Y,B^,XORPut);
  setcolor(black);
  setfillstyle(solidfill,black);
  bar(2,2,448,400);
  SetColor(Yellow);
  SetTextStyle(SansSerifFont,HorizDir,6);
  OutTextXY(150,200,concat('Level ',nameoflev));
  readkey;
  setcolor(black);
  setfillstyle(solidfill,black);
  bar(2,2,448,400);
  bar(535,350,556,380);
  SetColor(cyan);
  SetTextStyle(TriplexFont,HorizDir,2);
  OutTextXY(540,350,nameoflev);
  DrawBlocks(numoflev);
  Beg_of_pad := 155;
  BallPos.X := 190;
  BallPos.Y := 455;
  PutImage(beg_of_pad,460,P^,XORPut);
  PutImage(BallPos.X,BallPos.Y,B^,XORPut);
End;
{-----------------------------------------}
Procedure GamOvr;
Var
 k :byte;
Begin
  Rcrd := true;
  For k := 1 to 10 do
    if score > max.score[k] then begin
        Recrd(k);
        rcrd := false;
      end;
  ClearDevice;
  SetTextStyle(3,0,8);
  SetColor(Magenta);
  OutTextXY(100,180,'Game Over');
  ReadLn;
  CloseGraph;
  Halt(1);
End;{GamOvr}
{----------------------------------}
Function TestBricks:Boolean;
Var
  i:Integer;
Begin
  TestBricks:=false;
  For i := 1 to 84 do
  begin
    With blocks[i] do
    begin
      if style <> 0 then
      begin
        if (BallPos.X+6 > X) and (BallPos.X < X + 30) and
           (BallPos.Y+6 > Y) and (BallPos.Y<y+15) then
          begin
            TestBricks:=True;
            AddX:=X;
            AddY:=Y;
            Num:=I;
            if (LastPos.X+6>X)and(LastPos.X<X+30) then
              Side:=false
            else
              Side:=True;
          end;
      end;
    end;
  End;
End;{TestBricks}
{-----------------------------------}
Procedure DrawBlocks(numlev : byte);
Var
  i,j:Byte;
Begin
  count_of_bricks := 0;
  i := 1;
  while not EOF(level) and (i <= 84) do
   begin
    read(level,blocks[i].style);
    inc(i);
   end;

  AddX:=17;
  AddY:=15;
  for i := 0 to 6 do
  begin
    For j := 1 to 12 do
    begin
      case blocks[i*12+j].style of
        1: begin
             PutImage(AddX,AddY,Brick[1]^,XorPut);
             inc(count_of_bricks);
           end;
        2: begin
             PutImage(AddX,AddY,Brick[2]^,XorPut);
             Inc(count_of_bricks);
           end;
        3: PutImage(AddX,AddY,Brick[3]^,XorPut);
      end;
      With blocks[i*12+j] do
        begin
         x := AddX;
         y := AddY;
        end;
      AddX:=AddX+35
    end;
  AddX:=17;
  AddY:=AddY+20
  end;
End;{DrawBlocks}
{------------------------------}
Procedure Initg;
Var
  j,Gd,Gm:Integer;
  addscore :string;
Begin
  if (RegisterBGIFont(@TRIPFONT) < 1) or
     (RegisterBGIFont(@LITTFONT) < 1) or
     (RegisterBGIFont(@sansFONT) < 1) then Halt(1);
  if RegisterBGIDriver(@VGADRV) < 1 then Halt(1);
  Gd := VGA;Gm:=VGAhi;
  InitGraph(Gd, Gm,path);
  if GraphResult <> grOk then
    Write(GraphErrorMsg(GraphResult))
  else begin
   numoflev := 0;
   score := 0;
   {-==-}
   assign(Tbl,'arkscore.dat');
   {$I-}
   Reset(Tbl);
   {$I+}
   if IOResult <> 0 then
     ReWrite(tbl);
   FindFirst('arkscore.dat',AnyFile,s);
   if s.size = 0 then
     begin
       max.Score[1] := 9;
       max.name[1] := 'Coder';
       Seek(tbl,0);
       Write(tbl,max);
       Close(tbl);
       Reset(tbl);
     end;
   {$I-}
   Read(tbl,max);
   {$I+}
   If IOResult <> 0 then Halt;
   SetColor(LightRed);
   SetTextStyle(SmallFont,0,5);
   for j := 1 to 10 do
    begin
     Str(max.score[j],Addscore);
     OutTextXY(470,100+j*20,max.name[j]);
     OutTextXY(580,100+j*20,addscore);
    end;
   SetColor(Blue);
   Settextstyle(SansSerifFont,0,4);
   OutTextXY(500,80,'BEST''s');
   {-==-}
   SetLineStyle(SolidLn,1,123);
   SetColor(Blue);
   Rectangle(0,0,450,GetMaxY);
   Rectangle(1,1,449,GetMaxY-1);
   SetColor(Green);
   Rectangle(451,0,GetMaxX,GetMaxY);
   Rectangle(452,1,GetMaxX-1,GetMaxY-1);
   {-==-}
   SetTextStyle(SansSerifFont,HorizDir,4);
   SetColor(Yellow);
   OutTextXY(475,10,'ARKENOID');
   SetTextStyle(SmallFont,HorizDir,4);
   SetColor(LightGreen);
   OutTextXY(475,50,'Written by Kesha Enikeew');
   SetTextStyle(TriplexFont,HorizDir,2);
   SetColor(Cyan);
   OutTextXY(475,350,'Level');
   OutTextXY(475,400,'Score 0');
   {-==-}
   SetColor(LightMagenta);
   SetFillStyle(BkSlashFill,Magenta);
   Bar3d(100,100,130,115,0,false);
   Size:=ImageSize(100,100,130,115);
   GetMem(Brick[1],size);
   GetImage(100,100,130,115,Brick[1]^);
   PutImage(100,100,Brick[1]^,XORPut);
   {-==-}
   SetColor(LightGreen);
   SetFillStyle(XHatchFill,Green);
   Bar3d(100,100,130,115,0,false);
   Size:=ImageSize(100,100,130,115);
   GetMem(Brick[2],size);
   GetImage(100,100,130,115,Brick[2]^);
   PutImage(100,100,Brick[2]^,XORPut);
   {-==-}
   SetColor(White);
   SetFillStyle(SolidFill,White);
   Bar(100,100,130,115);
   Size:=ImageSize(100,100,130,115);
   GetMem(Brick[3],size);
   GetImage(100,100,130,115,Brick[3]^);
   PutImage(100,100,Brick[3]^,XORPut);
   {-==-}
   SetColor(LightGreen);
   Circle(100,100,3);
   SetColor(LightBlue);
   Circle(100,100,2);
   SetColor(LightMagenta);
   Circle(100,100,1);
   Size:=ImageSize(97,97,103,103);
   GetMem(B,Size);
   GetImage(97,97,103,103,b^);
   PutImage(97,97,B^,XORPut);
   Beg_of_pad := 155;
   BallPos.X := 190;
   BallPos.Y := 455;
   MainX:=2;
   MainY:=-2;
   DrawPad;
   Size:=ImageSize(155,460,225,470);
   GetMem(P,Size);
   GetImage(155,460,225,470,P^);
   PutImage(BallPos.x,BallPos.Y,B^,XORPut);
  end;
End;{initg}
{---------------------------------------}
Procedure DrawPad;
Begin
  SetFillStyle(1,LightGreen);
  Bar(Beg_of_pad,460,Beg_of_pad+70,470);
  SetFillStyle(1,Yellow);
  Bar(Beg_of_pad+5,463,Beg_of_pad+65,467);
End;{DrawPad}
{-----------------------------------------------}
Procedure MovePad(value:Integer);
Begin
  PutImage(Beg_of_pad,460,P^,XORPut);
  if Beg_of_pad + value >= 377
  then Beg_of_pad:=377
  else
    if Beg_of_pad + value <= 2
    then Beg_of_pad := 2
    else Beg_of_pad:=Beg_of_pad+value;
  PutImage(Beg_of_pad,460,P^,XORPut);
End;{MovePad}
{------------------------------------}
Procedure MoveBall;
var Sscore : string;
Begin
  PutImage(BallPos.X,BallPos.Y,B^,XORPut);
  case BallPos.Y of
    456 .. 480 : begin
                   if (BallPos.X>Beg_of_pad-6)and(BallPos.X<Beg_of_pad+70)
                     then begin
                       MainY:=-(random(2)+1);
                       if MainX > 0 then MainX := random(2)+1
                       else MainX := -(random(2)+1);
                     End;
                   if (BallPos.X < Beg_of_pad-2) or (BallPos.X > Beg_of_pad+70) then GamOvr;
                 end;
    0 .. 2     : begin
                   MainY := Random(2)+1;
                   if MainX > 0 then MainX := Random(2)+1
                   else MainX := -(Random(2)+1);
                 end;
  end;
  if (BallPos.X < 3) or (BallPos.X > 442) then MainX:=-MainX;
  if TestBricks then
  begin
    case blocks[num].style of
     1: begin
         PutImage(AddX,AddY,Brick[1]^,XORPut);
         blocks[NUM].style:=0;
         Dec(Count_of_bricks);
         inc(score,15);
        end;
     2: begin
         PutImage(AddX,AddY,Brick[2]^,XORPut);
         PutImage(AddX,AddY,Brick[1]^,XORPut);
         blocks[num].style := 1;
         inc(score,10);
        end;
     3: inc(score,5);
    end;
    if side then MainX:=-MainX else MainY:=-MainY;
    Str(score,Sscore);
    SetColor(Black);
    SetFillStyle(SolidFill,Black);
    bar(535,400,636,430);
    SetColor(cyan);
    SetTextStyle(TriplexFont,HorizDir,2);
    OutTextXY(540,400,Sscore);
  end;
  LastPos.X:=BallPos.X;
  LastPos.Y:=BallPos.Y;
  BallPos.X:=BallPos.X+MainX;
  BallPos.Y:=BallPos.Y+MainY;
  PutImage(BallPos.X,BallPos.Y,B^,XORPut);
  Delay(100);
End;{MoveBall}
{---------------------------------}
Procedure Play;
Var
w:word;
c:char;
Begin
  nextlev;
  repeat
    if count_of_bricks = 0 then nextlev;
    moveball;
    if keypressed then
    begin
      c := readkey;
      if c = #27 then GamOvr;
      if c = #0 then w := ord(readkey);
      case w of
        77 : movepad(15);
        75 : movepad(-15);
      end;
    end;
  until false;
End;{Play}
{--------------------------------------}
Begin
 Randomize;
 Initg;
 Play;
End.