Hra ponorka

Kategórie: KMP (Programy mladých programátorů)
Autor: Masopust (Empty Head)
Program: Ponorka.pas
Soubor exe: Ponorka.exe
Potřebné: Ponorka.sco,  Egavga.obj,  Trip.obj

{ ponorka.pas                           Copyright (c) Petr Masopust  }
{ Hra ponorka. Musis sa vyhybat minama a minolovke.                  }
{                                                                    }
{ Datum:07.09.2018                              http://www.trsek.com }
uses dos,crt,graph;
type bod=record x,y:integer; end;
type
    CharSet = set of char; { množina všech znaků }
    Retezec = string[80];
 
 
const maxenergy:integer=200;
      pozadi:byte=blue;
      pridavek:integer=30;
   Null    =   #0; { znak NULL }
   BS      =   #8; { kl vesa BACKSPACE }
   CR      =  #13; { kl vesa ENTER }
   Esc     =  #27; { kl vesa ESC }
   Space   =  #32; { mezerník }
   F1      = #187; { funkční klíč 1 }
   F2      = #188; { funkční klíč 2 }
   F3      = #189; { funkční klíč 3 }
   F4      = #190; { funkční klíč 4 }
   F5      = #191; { funkční klíč 5 }
   F6      = #192; { funkční klíč 6 }
   F7      = #193; { funkční klíč 7 }
   F8      = #194; { funkční klíč 8 }
   F9      = #195; { funkční klíč 9 }
   F10     = #196; { funkční klíč 10 }
   Home    = #199; { kl vesa HOME }
   EndK    = #207; { kl vesa END }
   Ins     = #210; { kl vesa INS }
   Del     = #211; { kl vesa DEL }
   Up      = #200; { kl vesa šipka nahoru }
   Down    = #208; { kl vesa šipka dolu }
   Left    = #203; { kl vesa šipka vlevo }
   Right   = #205; { kl vesa šipka vpravo }
   PgUp    = #201; { kl vesa stránka nahoru }
   PgDn    = #209; { kl vesa stránka dolu }
 
var en,gd,gm:integer;
    bomby:array[1..11] of bod;
    miny:array[1..10,3..9]of bod;
    l,x,y,xm,ym,body:integer;
    zdroj:bod;
    smer:boolean;
    c:char;
 
procedure egavgaovladac;external;
{$L egavga.obj}
procedure triplexfontovladac;external;
{$L trip.obj}
 
procedure clearta;assembler;
asm
  mov ax,0c06h
  mov dl,0ffh
  int 21h
end;
 
 
procedure prekreslilod(l:integer);
begin
  setfillstyle(solidfill,black);
  bar(l*(getmaxx div 22)-12,97,l*(getmaxx div 22)+12,100);
  bar(l*(getmaxx div 22)-2,93,l*(getmaxx div 22)+2,97);
  setfillstyle(solidfill,pozadi);
  bar(l*(getmaxx div 22)-12,100,l*(getmaxx div 22)+12,102);
end;
 
procedure lodicka(x,y:integer);
begin
  prekreslilod(l);
  if smer then inc(l)
  else dec(l);
  if l >= 21 then smer:=not(smer);
  if l <= 1 then smer:=not(smer);
  setfillstyle(solidfill,lightgray);
  bar(l*(getmaxx div 22)-12,97,l*(getmaxx div 22)+12,102);
  bar(l*(getmaxx div 22)-2,93,l*(getmaxx div 22)+2,97);
  if abs(l*(getmaxx div 22)-x)<=20 then begin
    if bomby[(l+1) div 2].x = 0 then begin
      bomby[(l+1) div 2].x:=1;
      bomby[(l+1) div 2].y:=random(20);
    end;
  end;
end;
 
function inttostr(i:integer):string;
var
  S: string[11];
begin
  Str(I, S);
  IntToStr := S;
end;
 
procedure bodovani;
var c:byte;
    s:string;
begin
  c:=getcolor;
  s:='Body: '+inttostr(body);
  setfillstyle(solidfill,black);setcolor(black);
  settextstyle(triplexfont,horizdir,2);
  bar(17,50,textwidth(s)+17,50+textheight(s));
  setcolor(yellow);
  outtextxy(17,50,s);
  setcolor(c);
end;
 
    Function GetKey : char;
    var
       Key : char;
    begin
       ClearTA;
       repeat until keypressed;
       Key := ReadKey;   { precti znak z klavesnice }
       if (Key = Null) and KeyPressed then
       begin             { jestlize se jedna o rozsirenou
                           klavesu }
          Key := ReadKey;{ precti druhy byte kodu klavesy }
          Key := Chr(Ord(Key)+128);
       end;
       GetKey := (Key);
    end;
 
    function GetLegalKey(LegalSet : CharSet) : char;
    var
       Key : char;
    begin
       repeat
          Key := GetKey;     { cekej na vstup z klavesnice}
       until Key in LegalSet;{ patri znak do mnoziny ? }
       GetLegalKey := Key;
    end;
 
    function GetKeyb : char;
    var
       Key : char;
    begin
       ClearTA;
       Key := ReadKey;
       if (Key = Null) then
       begin
          Key := ReadKey;
          Key := Chr(Ord(Key)+128);
       end;
       GetKeyb := Key;
    end;
 
    function GetString : Retezec;
    { Delka : delka pole, do ktereho se ma retezec vkladat }
 
    function Input(Delka : byte;
                   var R : Retezec) : char;
    { Funkce  ceka  na  vstup  z  klavesnice  a  vraci  znakovou
      reprezentaci stisknute klavesy. }
    var
       Znak: char;           { vkladany znak }
       D   : byte absolute R;{ aktualni delka vkladaneho retezce}
    begin
       Znak:= GetLegalKey([#32..#126, BS, CR, ESC]);
       case Znak of
       { jestlize se stiskne zobrazitelny znak ze  spodni  poloviny
         tabulky ASCII a aktualni delka retezce je mensi nez povolene
         maximum, znak se prida do retezce  a  zobrazi  za  poslednim
         znakem retezce }
         #32..#126 : if D < Delka then
                     begin
                        R := R + Znak;
                        outtext(Znak);
                    end;
        ESC       : R := ESC;
      end;
      Input := Znak;
    end;
 
    var
       R  : Retezec;
       Z  : char;
 
    begin
  cleardevice;
  setcolor(yellow);
  settextstyle(triplexfont,horizdir,4);
  outtextxy(100,100,'Napis sve jmeno:');
  moveto(100,150);
  setcolor(lightblue);
       R := '';
       repeat
           Z := Input(20, R);
       until Z in [ESC, CR];
       if R <> ESC then
           GetString := R
       else
           GetString := '';
  cleardevice;
end;
 
procedure score;
type
  tab=record name:string[20];bodu:longint; end;
  tabule=array[1..11] of tab;
var f: file of tabule;
    t:tabule;
    pom:tab;
    m:longint;
    p:byte;
    i,j:byte;
    cte:boolean;
 
    {trideni}
    n,s:byte;
    l,r:array[1..11] of longint;
    l1,r1:longint;
 
begin
  assign(f,'PONORKA.SCO');
  {$I-}
  reset(f);
  read(f,t);
  if ioresult <> 0 then for i:=1 to 10 do begin t[i].name:='Empty Head'; t[i].bodu:=500; end;
  close(f);
  {$I+}
  cleardevice;
  m:=maxlongint;
  cte:=false;
  if t[10].bodu < body then begin
    t[11].name:=getstring;
    t[11].bodu:=body;
  end else begin
    t[11].name:='';
    t[11].bodu:=0;
  end;
  {trideni}
  n:=11;
 
  s:=1;
  l[1]:=1;
  r[1]:=n;
  repeat
    l1:=l[s];
    r1:=r[s];
    s:=s-1;
    repeat
      i:=l1;
      j:=r1;
      y:=((l1+r1) div 2);
      x:=t[y].bodu;
      repeat
        while t[i].bodu>x do i:=i+1; {obratit}
        while x>t[j].bodu do j:=j-1;           {obratit}
 
        if i<=j then
        begin
          pom.name:=t[i].name;
          t[i].name:=t[j].name;
          t[j].name:=pom.name;
          pom.bodu:=t[i].bodu;
          t[i].bodu:=t[j].bodu;
          t[j].bodu:=pom.bodu;
          i:=i+1;
          j:=j-1;
        end;
      until i>j;
      if i<r1 then
      begin
        s:=s+1;
        l[s]:=i;
        r[s]:=r1;
      end;
      r1:=j;
    until l1>r1;
  until s=0;
 
  settextstyle(triplexfont,horizdir,5);
  setcolor(red);
  outtextxy(100,20,'Vysledkova listina');
  settextstyle(triplexfont,horizdir,4);
  setcolor(yellow);
  outtextxy(100,60,'1. '+inttostr(t[1].bodu)+'  '+t[1].name);
  setcolor(lightblue);
  settextstyle(triplexfont,horizdir,3);
  for i:=2 to 10 do outtextxy(100,60+i*textheight(inttostr(i)+'. '+inttostr(t[i].bodu)+'  '+t[i].name),inttostr(i)+'. '
                     +inttostr(t[i].bodu)+'  '+t[i].name);
  clearta;
  repeat until keypressed;
  {$I-}
  rewrite(f);
  write(f,t);
  close(f);
  {$I+}
end;
 
procedure mina(x,y:integer);
begin
  setfillstyle(solidfill,darkgray);
  fillellipse(x,y,10,10);
end;
 
PROCEDURE prekresli(x,y:integer);
begin
  setfillstyle(solidfill,pozadi);
  bar(x-10,y-3,x+10,y+3);
end;
 
procedure ponorka(x,yy:integer);
begin
  setfillstyle(solidfill,lightgray);
  fillellipse(x,y,10,3);
end;
 
procedure main;forward;
 
procedure vybuch(x,y:integer);
var i:byte;
begin
  setfillstyle(solidfill,red);
  fillellipse(x,y,10,10);
  delay(1000);
  cleardevice;
  settextstyle(triplexfont, horizDir,4);
  outtextxy(100,100,'Zahynul jsi hrdinnou smrti !');
  delay(1000);
  settextstyle(triplexfont, horizDir,3);
  outtextxy(60,200,'Stiskni Z pro novou hru, jine klavesy konec.');
  clearta;
  repeat until keypressed;
  if upcase(readkey) <>'Z' then begin score; closegraph; halt;end;
  score;
  for i:=1 to 11 do bomby[i].x:=0;
  main;
  halt;
end;
 
procedure vybuchbomby(x,y:integer);
var c:byte;
begin
  c:=getcolor;
  setcolor(pozadi);
  setfillstyle(solidfill,red);
  fillellipse(x,y,10,10);
  delay(100);
  setfillstyle(solidfill,pozadi);
  fillellipse(x,y,10,10);
  setcolor(c);
end;
 
procedure bombs(x,y:integer);
var i,c:byte;
    xp,yp:integer;
begin
  for i:=1 to 11 do begin
    if bomby[i].x <> 0 then begin
      xp:=(i*2-1)*(getmaxx div 22);
      yp:=((getmaxy-110) div 20)*bomby[i].x+110;
      if (abs(yp-y)<=10)and(abs(xp-x)<=10) then vybuch(x,y);
      if bomby[i].x=bomby[i].y then begin
        bomby[i].x:=0;
        vybuchbomby(xp,yp);
        continue;
      end;
      c:=getcolor;
      setfillstyle(solidfill,pozadi);
      setcolor(pozadi);
      xp:=(i*2-1)*(getmaxx div 22);
      yp:=((getmaxy-110) div 20)*bomby[i].x+110;
 
      fillellipse(xp,yp,10,10);
      inc(bomby[i].x);
      setfillstyle(solidfill,yellow);
      xp:=(i*2-1)*(getmaxx div 22);
      yp:=((getmaxy-110) div 20)*bomby[i].x+110;
 
      fillellipse(xp,yp,10,10);
      setcolor(c);
    end;
  end;
end;
 
function ismina(x,y:integer):boolean;
begin
  ismina:=false;
  for gd:=1 to 9 do for gm:=3 to 9 do if (abs(miny[gd,gm].x-x)<=10)and(abs(miny[gd,gm].y-y)<=10) then ismina:=true;
end;
 
procedure kreslizdroj;
var c:byte;
begin
  c:=getcolor;
  setcolor(lightred);
  setfillstyle(closedotfill,lightred);
  fillellipse(zdroj.x,zdroj.y,10,10);
  setcolor(c);
end;
 
procedure energy(x,y:integer);
var c:byte;
begin
  setfillstyle(solidfill,black);
  bar(15,10,625,30);
  if en <=0 then vybuch(x,y);
  if (abs(zdroj.x-x)<=10)and(abs(zdroj.y-y)<=10) then begin
    inc(en,pridavek);
    inc(body,100);
    c:=getcolor;
    setcolor(pozadi);
    setfillstyle(solidfill,pozadi);
    fillellipse(zdroj.x,zdroj.y,10,10);
    setcolor(c);
    repeat
      zdroj.x:=random(getmaxx);
      zdroj.y:=120+random(getmaxy-120);
    until not(ismina(zdroj.x,zdroj.y));
    kreslizdroj;
  end;
  if paramstr(1) = 'cheat' then en:=maxenergy;
  if en > maxenergy then en:=maxenergy;
  if en >= 25 then setfillstyle(solidfill,cyan)
  else begin
    sound(100 div en * 100);
    delay(10);
    nosound;
    setfillstyle(solidfill,red);
  end;
  bar(15,10,en * ((getmaxx-30) div maxenergy)+15,30);
  dec(en);
end;
 
procedure bomba(x,y:integer);
begin
  setfillstyle(solidfill,lightgray);
  fillellipse(x,y,3,3);
end;
 
procedure main;
var h,m,s,hund:word;
    time,time1:longint;
begin
  cleardevice;
  setfillstyle(solidfill,pozadi);
  bar(0,100,getmaxx,getmaxy);
  for gd:=1 to 10 do for gm:=3 to 9 do begin
    miny[gd,gm].x:=gd*getmaxx div 11;
    miny[gd,gm].y:=gm*getmaxy div 10;
    mina(miny[gd,gm].x,miny[gd,gm].y);
  end;
  x:=10;y:=110;
  l:=19;
  body:=0;
  ponorka(x,y);
  bodovani;
  lodicka(x,y);
  repeat
    zdroj.x:=random(getmaxx);
    zdroj.y:=100+random(getmaxy-100);
  until not(ismina(zdroj.x,zdroj.y));
  kreslizdroj;
  setfillstyle(solidfill,cyan);
  bar(15,10,15+en*6,30);
  xm:=x;ym:=y;
  en:=maxenergy;
  energy(x,y);
  repeat
  clearta;
{$ifndef kunz}
  c:=#0;
  gettime(h,m,s,hund);
  time:=h*360000 + m*6000 + s*100 +hund;
  repeat
    if keypressed then begin
      c:= ReadKey;
      if (c = Null) and KeyPressed then
       begin
         c := ReadKey;
         c := Chr(Ord(c)+128);
       end;
   end;
    gettime(h,m,s,hund);
    time1:=h*360000 + m*6000 + s*100 +hund;
  until time1-time >= 10;
{$else}
  repeat
    c:=readkey;
  until (c=left)or(c=right)or(c=up)or(c=down)or(c=esc);
{$endif}
  case c of
  up: dec(y,10);
  down: inc(y,10);
  left: dec(x,10);
  right: inc(x,10);
  end;
  if y <= 100  then y:=110;
  if y >= getmaxy  then y:=getmaxy-10;
  if x <= 0  then x:=10;
  if x >= getmaxx  then x:=getmaxx-10;
  if ismina(x,y) then vybuch(x,y);
  lodicka(x,y);
  prekresli(xm,ym);
  energy(x,y);
  bodovani;
  ponorka(x,y);
  bombs(x,y);
  xm:=x;ym:=y;
  until c = esc;
  closegraph;
end;
 
begin
  if paramstr(1) = '/?' then begin
    clrscr;
    writeln;
    writeln('  Ovladani:');
    writeln;
    writeln('  Esc ... konec programu.');
    writeln('  Sipky ... pohyb ponorky');
    writeln;
    writeln('  Pokud nekdo nakresli (v jakemkoli graf. formatu napr. BMP) dobrou minu,');
    writeln('  ponorku, lod atd. at ji necha ve skole na pocitaci s CD-ROM v adresari s touto  hrou.');
    writeln;
    writeln('  V zajmu pouzitelnosti i ve skole pouzivejte pouze 16 zakladnich barev');
    writeln('  viz napr. Paintbrush. Rozmery:');
    writeln;
    writeln('  Lod - 24 x 5 pixelu');
    writeln('  Mina - 20 x 20 pixelu');
    writeln('  Ponorka - 20 x 6 pixelu');
    writeln('  Vybuch - 20 x 20 pixelu');
    writeln('  Bomba - 20 x 20 pixelu');
    writeln;
    writeln('  Stiskni klavesu ...');
    clearta;
    repeat until keypressed;
  end;
  if registerbgidriver(@egavgaovladac) <0 then begin
    writeln('Chyba pri inicializaci grafiky !');
    halt;
  end;
  if RegisterBGIfont(@triplexfontovladac) < 0 then begin
    WriteLn('Chyba pri inicializaci fontu !');
    Halt;
  end;
  randomize;
  gd:=9;
  gm:=2;
  initgraph(gd,gm,'');
  setcolor(red);
  settextstyle(triplexfont,horizdir,7);
  outtextxy(130,100,'Hra PONORKY');
  settextstyle(triplexfont,horizdir,5);
  setcolor(lightblue);
  outtextxy(30,200,'Naprogramoval Empty Head');
  settextstyle(triplexfont,horizdir,4);
  setcolor(blue);
  outtextxy(100,300,'Napoveda PONORKA.EXE /?');
  setcolor(cyan);
  outtextxy(200,400,'Stiskni cokoli');
  clearta;
  repeat until keypressed;
  main;
end.