zrout.pas

{ zwei.stein@worldonline.cz, zweistein.kgb.cz }
program zrout;

{
 (c) Petr "Zweistein" Prokop

 Program ¦rout :
  Upraveně source jedn‚ primitivnˇ hry
}

uses Crt;
type vektor=array[2..78, 2..24] of Byte;
var M, N:Shortint;Z:Char;hudba,X, Y, P, zaz:Byte;po:vektor;body,ob,mode, rekord:Word;
function cekej:Char;
var P:Char;
begin
  repeat
    P:=ReadKey;
  until P<>'';
  cekej:=P;
end;
function sipky:Byte;
var Z:Char;P:Byte;
begin
  repeat
    Z:=cekej;
  until Ord(Z)=0;
  Z:=cekej;
  P:=Ord(Z);
  sipky:=P;
end;
procedure print(X, Y:Byte;Z:Char);
begin
  GotoXY(X, Y);
  Write(Z);
end;
procedure ramecek(X, Y, M, N:Byte;Z:Char);
var P:Byte;
begin
  for P:=X to M do begin print (P, Y, Z);print (P, N, Z);end;
  for P:=Y to N do begin print (X, P, Z);print (M, P, Z);end;
end;
procedure zmensmer(var X, Y:Shortint);
var Z:Char;P:Byte;
begin
  Z:=ReadKey;
  P:=Ord(Z);
  if P=0 then
    begin
      Z:=ReadKey;
      P:=Ord(Z);
      if hudba = 1 then begin Sound(3000);Delay(50);NoSound;end;
      if P=72 then begin Y:=-1;X:=0;end;
      if P=80 then begin Y:=1;X:=0;end;
      if P=77 then begin X:=1;Y:=0;end;
      if P=75 then begin X:=-1;Y:=0;end;
    end;
end;
procedure zprava(var U:Byte);
var Z:Byte;
begin
  GotoXY(15, 1);
  if(U=2) or (U=1) then Write('*********  MAć ZµZRA¬NOU MOC  **********');
  if(U=0) or (U=3) then Write('- - - - - - - - - - - - - - - - - - - - ');
  if U=1 then U:=3 else if U=3 then U:=1;
end;
procedure zprtxt(U:Byte);
begin
  zprava (U);
end;
procedure pohyb(var X, Y, Z,hudba:Byte;var po:vektor;var body:Word);
var P, K, L, lek, ind, zaz, prep:Byte;M, N:Shortint;poc:Integer;
begin
  X:=2;Y:=24;print(X, Y, 'H');K:=X;L:=Y;body:=0;Z:=0;lek:=0;prep:=1;
  M:=5;N:=5;
  repeat;
    zmensmer(M, N);
    until (M=1) or (M=-1) or (N=1) or (N=-1);
  X:=X+M;Y:=Y+N;
  repeat;
    repeat;
      print(K, L, ' ');
      if lek=0 then print (X, Y, 'H') else print(X, Y, 'Z');
      K:=X;L:=Y;zaz:=0;
      if lek>0 then lek:=lek-1;
      if (lek>0) and (lek<50) then begin print (X, Y, 'z');zprava (prep);end;
      if lek=0 then zprtxt(0);
      if lek>=50 then zprtxt(2);
      if (lek>0) and (lek<7) then begin if hudba = 1 then begin Sound(3000);Delay(50);NoSound;end;end;
      GotoXY(65, 1);Write('Score:', body);
      Delay(1000);
      if KeyPressed=True then zmensmer(M, N);
      X:=X+M;Y:=Y+N;
      if hudba = 1 then begin Sound(300);Delay(10);NoSound;end;
      until (X<2) or (X>78) or (Y<3) or (Y>24) or (po[X, Y]<>0);
    if po[X, Y]=Ord('*') then begin po[X, Y]:=0;if hudba = 1 then begin Sound(2000);
                                                                   Delay(75);NoSound;end;body:=body+1;zaz:=1;end;
    if po[X, Y]=Ord('+') then begin po[X, Y]:=0;if hudba = 1 then begin Sound(1000);Delay(100);NoSound;end;lek:=150;zaz:=1;end;
    if (po[X, Y]=Ord('s')) and (lek>0) then begin po[X, Y]:=0;if hudba = 1 then begin
                                                    Sound(100);Delay(120);NoSound;end;zaz:=1;body:=body+10;end;
  until zaz=0;
  if po[X, Y]=Ord('j') then Z:=1;
  if po[X, Y]=Ord('s') then Z:=2;
end;
procedure mazpole(var po:vektor);
var X, Y:Byte;
begin
  for X:=2 to 78 do
    begin
      for Y:=2 to 24 do po[X, Y]:=0;
    end;
end;
procedure gennah(P:Byte;Z:Char;var po:vektor);
var poc, X, Y:Byte;
begin
  for poc:=1 to P do
    begin
      repeat;
        repeat;
          repeat;
            X:=Random(79);
          until X>=2;
          repeat;
            Y:=Random(25);
          until Y>=3;
        until not(((X=2) or (X=3)) and ((Y=24) or (Y=23)));
      until po[X, Y]=0;
      po[X, Y]:=Ord (Z);
      print(X, Y, Z);
    end;
end;
procedure vyhodnoceni(var body, rekord:Word ;zaz:Byte);
begin
  if zaz=0 then Writeln('  Narazil jsem do zdi !');
  if zaz=1 then Writeln('    SnŘdl jsem jed !');
  if zaz=2 then Writeln('   Chytil mŘ str §ce !');
  if body>rekord then begin Writeln(' ****** Nově rekord. *****');Writeln('       ',body);end;
  if body=rekord then begin Writeln('****** Rekord stejně. *****');Writeln('       ',body);end;
  if bodyrekord then rekord:=body;
end;
begin
  Randomize;rekord:=0;
  repeat;
   ClrScr;
   writeln ('---Hra ¦rout v2.5---');
   write ('Obtˇ§nost(1-250) :_');
   read (ob);
   write ('Hudba(1-ano,2-ne) :_');
   read (hudba);
   if ob > 250 then ob :=250;
   clrscr;
   ramecek (1, 2, 79, 25, Chr(219));
   mazpole(po);
   gennah(ob, '*', po);
   delay (500);
   gennah(ob, 'j', po);
   delay (500);
   gennah(ob, 's', po);
   delay (500);
   gennah(ob, '+', po);
    X:=1;Y:=1;zaz:=0;body:=0;
    pohyb (X, Y, zaz, hudba, po, body);ClrScr;
    WriteLn;
    vyhodnoceni(body, rekord,zaz);
    writeln;
    if ob+ob*10 = body then writeln ('      Jsi vˇtŘz!')
                       else writeln ('     Prohr l jsi!');
    writeln;
    if hudba = 1 then begin;
                        Sound(250);Delay(500);NoSound;
                        Sound(300);Delay(500);NoSound;
                        Sound(250);Delay(1000);NoSound;
                        Sound(300);Delay(800);NoSound;
                        Sound(300);Delay(2500);NoSound;
                        Sound(310);Delay(1040);NoSound;
                        Sound(300);Delay(2000);NoSound;
                        Sound(278);Delay(2250);NoSound;
                        Sound(333);Delay(900);NoSound;
                        Sound(300);Delay(1250);NoSound;
                        Sound(300);Delay(2154);NoSound;
                        Sound(278);Delay(2200);NoSound;
                      end;
    Write(' Chceç hr t znovu A/N ?');
    repeat;
      Z:=ReadKey;
    until((Z='a') or (Z='A') or (Z='n') or (Z='N'));
  until((Z='n') or (Z='N'));
end.
repeat;
zmensmer(X, Y);
WriteLn(X, Y);
until Y=-1;
end.