Hra Videostop v pascale podľa slávneho televízneho programu

{ VIDEOSTO.PAS              Copyright (c) TrSek alias Zdeno Sekerak }
{ Na motiv klasickej pocitacovej hry zo zabavnej relacie VIDEOSTOP. }
{ V subore video.dat su vsetky potrebne nastavenia.                 }
{                                                                   }
{ Datum:08.11.1995                             http://www.trsek.com }
 
program videostop(input,output);
 
uses crt,dos,graph,trsek;
type tfarby=0..16;
 
     rgbCol= record
     red:byte;
     green:byte;
     blue:byte;
     default:byte;
     end;
 
const { *** Definicia farieb pre 10 grafickych kariet *** }
      far:array[1..10,0..15] of tfarby =
      ((0,1,2,3,4,5,6,7,8,9,10,11,15,13,14,15),
      (0,1,2,3,2,2,6,7,8,11,14,1,0,0,0,0),
      (0,1,2,3,4,5,6,7,8,9,10,11,15,13,14,15),
      (0,1,2,3,4,5,6,7,8,9,10,11,15,13,14,15),
      (0,1,2,3,4,5,6,7,8,9,10,11,15,13,14,15),
      (0,1,2,3,4,5,6,7,8,9,10,11,15,13,14,15),
      (0,0,0,3,0,0,0,0,0,9,10,11,15,13,0,1),
      (0,1,2,3,4,5,6,7,8,9,10,11,15,13,14,15),
      (0,1,2,3,4,5,6,7,8,9,10,11,15,13,14,15),
      (0,1,2,3,4,5,6,7,8,9,10,11,15,13,14,15));
 
      { *** Vypisovat nazov programu *** }
      nazov:array[1..9] of char =
      ('V','I','D','E','O','S','T','O','P');
 
      { *** Vypisovat PREMIA ak uhadol 3 rovnake *** }
      prem:array[1..6] of char =
      ('P','R','E','M','I','A');
 
      { *** Kde su umiestnene body kocky na obrazovke *** }
      bod:array[1..2,1..7] of integer =
      ((30,90,30,60,90,30,90),(35,35,65,65,65,95,95));
 
      { *** Podla bodu, ktore vykreslovat ma kocke so & *** }
      hod:array[1..6,1..7] of byte=
      ((0,0,0,1,0,0,0),(0,1,0,0,0,1,0),(0,1,0,1,0,1,0),
       (1,1,0,0,0,1,1),(1,1,0,1,0,1,1),(1,1,1,0,1,1,1));
 
      { *** Kolko bodov maju jednotlive ceny *** }
      bceny:array[1..8] of integer=
      (0,50,100,500,1000,1500,2000,32000);
 
      { *** Ake ceny su *** }
      ceny:array[1..7] of string=
      ('Fen','Zehlicka','Radio','Friteza','Vysavac','Hi-Fi veza',
       'Satelit');
 
      { *** Ake karty obsuhujem *** }
      karty:array[1..10] of string=
      ('CGA','CGA','EGAVGA','EGAVGA','EGAVGA','IBM8514','HERC','ATT',
       'EGAVGA','PC3270');
 
      { *** Vyplne jednotlivych boxov *** }
      pattern:array[1..4] of fillpatterntype=
              (($ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff),
               ($36,$49,$55,$22,$22,$55,$49,$36),
               ($66,$99,$66,$99,$66,$99,$66,$99),
               ($7e,$bd,$db,$e7,$e7,$db,$bd,$7e));
 
      { *** Aku hudbu hrat pri vyhrach, prehrach, premii *** }
      dlz_hud_p=8;                                 { dlzka hudby pri premii }
      hudba_p:array[1..dlz_hud_p,1..2] of integer=
      ( (100,200),(200,100),(250,100),(100,200),
        (100,200),(200,100),(250,100),(100,200));
 
      dlz_hud=3;                                 { dlzka hudby obycajnej }
      hudba:array[1..3,1..dlz_hud,1..2] of integer=
      ( ( (600, 30),(200, 40),(  0,  0) ),      { *** Obycajne tuk,tuk *** }
        ( (100,100),(200,100),(300,100) ),      { *** Obycajne uhadnutie *** }
        ( (100,150),(200,150),(300,150) ));     { *** Zle uhadol *** }
      dpause=300;                               { *** Default pause *** }
      velkobr=3722;                             { *** Velkost BMP suboru *** }
 
var i,body,pocpo,pokus,pause:integer;
    black,blue,green,cyan,red,magenta,brown,lightgray,darkgray,lightblue,
    lightgreen,lightcyan,lightred,lightmagenta,yellow,white:integer;
    pok:array[1..28] of integer;
    por:array[1..3] of integer;
    gd,gm:integer;                              { *** Kvoli grafickej karty *** }
    error:integer;                              { *** Co gr chyba *** }
    kx,ky,px,py:real;
    par:string;
    ch:char;
    beep : Boolean;
    text_u_b : Boolean;
    mous : Boolean;                             { *** Ma mys A/N *** }
    put_mous : Boolean;                         { *** Stlacil mys A/N *** }
    old_put_mous : Byte;                        { *** Co bolo stlacene predtym *** }
    oldp,p:pointer;                             { *** Kvoli obrazku *** }
    cesta:string;
 
 
procedure EGAVGA_dr; external;
{$L EGAVGA.OBJ }
 
procedure get_mys_but;
var Reg:Registers;
begin
  if mous then begin
      Reg.AX:=$0003;
      Reg.BX:=$0001;
      Intr($33,Reg);
      if (Reg.BX=1) and (old_put_mous=0) then put_mous:=true;
      old_put_mous:=Reg.BX;
     end;
end;
 
 
{ *** Zinicializuje mys, ak existuje *** }
function init_mys:Boolean;
var Reg:Registers;
begin
 Reg.AX:=0;
 Intr($33,Reg);
 if Reg.AX=0 then init_mys:=false
             else init_mys:=true;
end;
 
 
{ *** Procedure tDelay ako nahrada *** }
procedure tDelay(de:integer);
var i:integer;
begin
 for i:=1 to de do begin
      delay(1);
      get_mys_but;
     end;
end;
 
 
{ *** A co takto aj readkey, aj keypressed pre mys *** }
function tReadKey:char;
var Reg:Registers;
    von:char;
begin
 von:=#0;
 repeat
 if mous then begin
      Reg.AX:=$0003;
      Reg.BX:=$0001;
      Intr($33,Reg);
      if (Reg.BX=1) and (old_put_mous=0) then von:=#13;
      if (Reg.BX=2) and (old_put_mous=0) then von:=#27;
      old_put_mous:=Reg.BX;
     end;
 if KeyPressed then von:=readkey;
 until (von<>#0);
 tReadKey:=von;
end;
 
 
{ *** Funkcia zistuje klaves, alebo stlacenie mysi *** }
 
function tKeyPressed:Boolean;
var Keyp:Boolean;                               { *** Stlacil klaves Ano/Nie *** }
begin
 Keyp:=KeyPressed;
 if keyp then begin
     ch:=tReadkey;
 
     if (ch=#27) then                           { *** Esc = koniec *** }
       begin
        closegraph;
        window(1,1,80,25);
        koniec('VideoStop v.3.1','95');
        halt(0);
       end;
 
     if (ch in [#62,#72,#80]) then begin
      if (ch=#62) then beep:=not(beep);      { *** F4 Sound On/Off *** }
      if (ch=#72) then pause:=pause-20;
      if (ch=#80) then pause:=pause+20;
      if (pause<0) then pause:=10;
      Keyp:=false;
     end;
 
     end;
 tKeyPressed:=Keyp;
 
 if put_mous then begin
     tKeyPressed:=true;
     put_mous:=false;
    end;
end;
 
 
procedure tread(var b:byte);
begin
 p:=Ptr(Seg(p^),Ofs(p^)+1);
 b:=byte(p^);
end;
 
 
function get_size:word;
var Sub:SearchRec;
begin
 FindFirst(paramstr(0),Archive or AnyFile or Hidden or ReadOnly,sub);
 get_size:=sub.size;
end;
 
{ *** Vykresli Dakujem anicke *** }
procedure dakujem( xd,yd:integer );
var  frgb:file of byte;
     f:file;
     ch:byte;
     x,y,i:integer;
     NumRead:word;
     rgbcolor:array[0..255] of rgbCol;
 
begin
 assign(f,paramstr(0));
 reset(f,1);
 getmem(p,3722);oldp:=p;
 seek(f,word(get_size-velkobr+118));
 BlockRead(f,p^,3604,NumRead);
 close(f);
 
 x:=0;y:=53;
 
 repeat
   tread(ch);
   inc(x);
   putpixel(x+xd,y+yd,ch div 16);
   inc(x);
   if (x>=132) then begin
      for i:=1 to 2 do tread(ch);
      x:=0;y:=y-1;
    end
   else putpixel(x+xd,y+yd,ch mod 16);
 until (y<1);
 
 freemem(oldp,3722);
end;
 
 
{ *** Vykresli ramcek s okrajom cervenej farby *** }
procedure Box( xl,yl,xp,yp,color,vzor : Integer);
begin
 SetFillPattern(pattern[1],RED);
 Bar(xl-2,yl-2,xp+2,yp+2);
 
 SetFillPattern(pattern[vzor],color);
 Bar(xl,yl,xp,yp);
end;
 
 
{ *** Hrat zvuky, alebo nie *** }
procedure tsound(i:integer);
begin
 if beep then sound(i);
end;
 
 
{ *** Podklad hry videostop. Ak typ=0 cely, ak typ=1 iba text VIDEOSTOPu *** }
procedure uvod( typ:integer );
var i:integer;
begin
 SetBKColor(lightgray);                         { *** Celkovy podklad hry *** }
 SetFillStyle(8,yellow);
 
 if typ=0 then begin                            { *** Chce cely podklad *** }
  bar(0,0,640,480);
 
  SetTextStyle(0,0,2);                           { *** Okno software by TRSEK *** }
  Box(25,450,470,476,black,1);
  SetColor(blue);
  OutTextXY(55,456,'Software by TRSEK  Corp.');
 
  SetFillStyle(0,cyan);
  Box(20,20,260,140,black,1);                   { *** Okno score *** }
  Box(285,20,430,140,darkgray,1);               { *** Okno pokusy *** }
  Box(13,158,437,312,red,4);                    { *** Okno kocky *** }
  Box(15,160,435,310,black,1);                  { *** V nom dalsie o 2 mensie okno *** }
 
  Box(25,170,145,300,magenta,4);                { *** Kocka 1 *** }
  Box(165,170,285,300,magenta,4);               { *** Kocka 2 *** }
  Box(305,170,425,300,magenta,4);               { *** Kocka 3 *** }
 end;
 
 SetFillStyle(0,cyan);
 Box(25,335,470,435,white,1);                  { *** Okno vyhra *** }
 Box(495,20,600,405,green,3);                  { *** Okno Videostop/Premia *** }
 
 box(490,420,622,475,green,1);
 dakujem(491,421);
 
 SetColor(yellow);
 SetTextStyle(0,0,4);                           { *** Do posledneho okna text videostop *** }
 for i:=1 to 9 do OutTextXY(538,5+40*i,nazov[i]);
 SetColor(blue);
 for i:=1 to 9 do OutTextXY(540,3+40*i,nazov[i]);
                                                { *** Nadefinuj si pocet bodov *** }
 if (pocpo>0) and (pocpo<30) then body:=pocpo-1
                              else
                              begin
                               body:=round(random(5))+9;
                               pocpo:=body+1;
                              end;
end;
 
 
{ *** Hraj hudbu 0- nedavaj nosound 1-davaj nosound za kazdym *** }
procedure hraj_hudbu( tt,typ:Integer );
var i:integer;
begin
 for i:=1 to dlz_hud do begin
     if (hudba[tt,i,2]<>0) then begin     { *** Iba ak je nenulova dlzka *** }
        tsound(hudba[tt,i,1]);
        tDelay(hudba[tt,i,2]);
       end;
     if typ=0 then nosound;
    end;
 nosound;
end;
 
 
{ *** Vystraja pri premii *** }
procedure premia;
var i,ii:integer;
begin
 Box(495,20,600,405,red,3);
 
 for ii:=1 to 3 do begin
     SetTextStyle(0,0,4);SetColor(white);
     for i:=1 to 6 do OutTextXY(535,60*i-10,prem[i]);
     tDelay(100);
     SetTextStyle(0,0,4);SetColor(green);
     for i:=1 to 6 do OutTextXY(535,60*i-10,prem[i]);
     tDelay(100);
 
     for i:=1 to dlz_hud_p do begin
     if (hudba_p[i,2]<>0) then begin     { *** Iba ak je nenulova dlzka *** }
        tsound(hudba_p[i,1]);
        tDelay(hudba_p[i,2]);
       end;
     end;
     nosound;
 
     tDelay(100);
    end;
 
 tDelay(500);
 uvod(1);                               { *** Znaovu zavolaj uvod *** }
end;
 
 
{ *** Vykresli kocku na pozicii, hodnota cis *** }
procedure kocka( poz,cis,tt:integer);
var i:integer;
begin
 por[poz]:=cis;
 Box(-115+poz*140,170,5+poz*140,300,white,1);
 get_mys_but;
 SetColor(magenta);
 SetTextStyle(0,0,3);
 get_mys_but;
 for i:=1 to 7 do
  if (hod[cis,i]=1) then begin
      OutTextXY((poz-1)*140+16+bod[1,i],156+bod[2,i],chr(3));
      get_mys_but;
     end;
 if tt=0 then tDelay(pause);
 hraj_hudbu(1,1);
end;
 
 
{ *** Spravne uhadol, vypise co vyhral *** }
procedure vyhral(v:integer);
begin
 Box(25,335,470,435,white,1);
 SetColor(darkgray);
 SetTextStyle(0,0,5);
 OutTextXY(50,365,ceny[v]);
 SetTextStyle(0,0,3);
 SetColor(red);
end;
 
 
{ *** Nahodny vyber cisla *** }
function cislo:integer;
var s:string;
begin
 pokus:=pokus+1;
 if (pokus>56) then pokus:=pokus-28;
 if (pokus=1)  then randomize;
 if (pokus>28) then cislo:=pok[pokus-28]
               else begin
                    pok[pokus]:=random(6)+1;
                    cislo:=pok[pokus];
                    end;
end;
 
 
{ *** Bodovanie podla toho ci uhadol, alebo nie *** }
procedure bodovanie(body:integer);
var s:string;
    i:integer;
begin
 pocpo:=pocpo-1;                        { Zniz pocet pokusov }
 Box(285,20,430,140,lightred,1);
 SetTextStyle(0,0,7);
 SetColor(darkgray);
 str(pocpo/100:2:2,s);
 delete(s,1,2);
 OutTextXY(310,57,s);
 
 Box(20,20,260,140,black,1);
 str(body/10000:4:4,s);
 delete(s,1,2);
 OutTextXY(35,57,s);
 for i:=1 to 7 do if (body>bceny[i]) and (body<bceny[i+1]) then vyhral(i);
end;
 
 
function kontrola:integer;
begin
  if (por[1]=por[2]) and (por[2]=por[3]) then begin
                                           kontrola:=body*3;
                                           premia;
                                           end
     else if (por[1]=por[2]) or (por[2]=por[3]) or (por[3]=por[1]) then
                                           begin
                                            kontrola:=body*2;
                                            hraj_hudbu(2,0);
                                           end
                                      else begin
                                            kontrola:=round(body/2-0.5);
                                            hraj_hudbu(3,1);
                                           end;
end;
 
 
{ koniec hry }
function zaver:boolean;
begin
 SetTextStyle(0,0,2);
 OutTextXY(50,413,'Chces este raz [../N]');
 ch:=tReadkey;
 if (ch='N') or (ch='n') or (ch=#27) then zaver:=true
                                     else zaver:=false;
end;
 
 
{ *** Uvodna textova obrazovka *** }
procedure text_uvod;
var s:string;
begin
 farba(0,15);
 clrscr;
 farba(blue,yellow);
 open_win(7,1,75,24,'VideoStop',1);
 textcolor(white);
 gotoxy(20,3);
 s:=' ';
 for i:=1 to 9 do s:=s+nazov[i]+' ';
 s:=s+' ver. 3.0';
 write(s);
 textcolor(yellow);
 for i:=1 to 7 do begin
   gotoxy(20,i+4);write(ceny[i]);
   str(bceny[i]:4,s);
   gotoxy(45,i+4);write(s);
 end;
 
 textcolor(lightgray);
 gotoxy(4,13);write('   Zdravim  Vas  pri  mojej verzii, ktora bola  vypracovana');
 gotoxy(4,14);write('   podla  znamej sutaznej hry, a  na vsetky  doteraz  zname');
 gotoxy(4,15);write('   graficke karty. Prajem Vam prijemnu zabavu bez namaceni.');
 gotoxy(4,17);write('   ovladanie: pokracuj (medzera, lave tlacitko mysi)');
 gotoxy(4,18);write('   ---------- koniec (ESC, prave tlacitko mysi) zvuk (F4)');
 gotoxy(4,19);write('              sipka hore,dole (rychlost hry)');
 gotoxy(50,23);write('Software by TRSEK');
 textcolor(yellow);
 gotoxy(4,21);write('Moja adresa: Zdeno Sekerak, Trnkov 18, Presov, 08212, Slovakia');
 
 textcolor(green);
 s:=chr(3)+' ';
 for i:=1 to 9 do s:=s+nazov[i];
 s:=s+' '+chr(3);
 
 repeat
  for i:=1 to 7 do begin
   s:=copy(s,2,length(s))+copy(s,1,1);
   gotoxy(4,i+4);write(s);kurzorzap(false);
   tsound(i*100);tDelay(20);nosound;
   end;
  for i:=1 to 7 do begin
   s:=copy(s,2,length(s))+copy(s,1,1);
   gotoxy(53,i+4);write(s);kurzorzap(false);
   tsound(i*300);tDelay(20);nosound;
   end;
 until tKeyPressed;
 
end;
 
 
{ *** Nadefinuj farby podla grafiskych kariet *** }
procedure defarby(t:integer);
begin
    black     :=far[t,0];  blue        :=far[t,1];
    green     :=far[t,2];  cyan        :=far[t,3];
    red       :=far[t,4];  magenta     :=far[t,5];
    brown     :=far[t,6];  lightgray   :=far[t,7];
    darkgray  :=far[t,8];  lightblue   :=far[t,9];
    lightgreen:=far[t,10]; lightcyan   :=far[t,11];
    lightred  :=far[t,12]; lightmagenta:=far[t,13];
    yellow    :=far[t,14]; white       :=far[t,15];
end;
 
 
{ *** Nadefinuj graficku kartu *** }
procedure defkartu;
{var error:integer;}
begin
 error:=grOk;
 if RegisterBGIdriver(@egavga_dr) < 0 then error:=-1;
 gd:=detect;
 detectgraph(gd,gm);
 initgraph(gd,gm,'');
 if graphresult<>0 then error:=-1;
 
 if Error <> grOk then begin
        textcolor(white);textbackground(black);
        window(1,1,80,24);
        clrscr;
        writeln(' Chyba pri inicializacii grafickej karty.');
        repeat until tKeyPressed;
        halt(0);
        end;
 kx:=getmaxx/640;ky:=getmaxy/480;
 px:=0;py:=0;
 defarby(gd);
end;
 
 
{ *** Vrat cislo z retazca *** }
function vali(s:string):integer;
var v,err:integer;
begin
 val(s,v,err);
 while ( (length(s)>0) and (err<>0) ) do begin
         delete(s,err,1);
         val(s,v,err);
        end;
 vali:=v+1;
end;
 
 
{ *** Vyber dalsi z config bez komentara *** }
function dalsi( var f:text ): string;
var s:string;
begin
 repeat
  readln(f,s);
 until not((s[1]=';') and not(eof(f)) );
 dalsi:=s;
end;
 
 
{ *** Vyber potrebne ceny z disku *** }
procedure zdisku;
var f:text;
    s:string;
    a:integer;
begin
 pause:=dpause;
 assign(f,cesta+'video.dat');
 {$I-}
 reset(f);
 {$I+}
 if ioresult=0 then begin
  for i:=1 to 7 do begin
    ceny[i]:=copy(dalsi(f),1,10);
    bceny[i]:=vali(dalsi(f));
    if (i>1) then
       if bceny[i-1]>bceny[i] then bceny[i]:=bceny[i-1]+1;
   end;
 
   repeat
    s:=dalsi(f);
    if copy(s,1,4)='POK=' then pocpo:=vali(s);
    if copy(s,1,4)='DEL=' then pause:=vali(s);
   until (eof(f));
 
   close(f);
 end;
end;
 
 
{ *** Vytvorenie default suboru VIDEO.DAT *** }
procedure default;
var f:text;
    i:integer;
begin
 writeln('Vytvaram default subor VIDEO.DAT');
 Assign(f,cesta+'video.dat');
 ReWrite(f);
 for i:=1 to 7 do begin
      writeln(f,ceny[i]);
      writeln(f,bceny[i]);
     end;
 writeln(f,'POK=12');
 writeln(f,'DEL=',dpause);
 close(f);
 halt(0);
end;
 
 
{ *** Help - ak zadal ako parameter programu /h *** }
procedure help;
begin
 writeln;
 writeln('Videostop ver 3.1');
 writeln('-----------------');
 writeln;
 writeln('Parametre:');
 writeln(' /h   - tento help');
 writeln(' /u   - bez uvodneho chaosu');
 writeln(' /s   - bez zvuku');
 writeln(' /b20 - s poctom pokusov 20');
 writeln(' /d   - vytvorenie default suboru VIDEO.DAT');
 writeln('                                                      Software by TRSEK');
 halt(0);
end;
 
{ *** S akymi parametrami bol spustany *** }
procedure get_param;
var   i:integer;
    par:string;
begin
 text_u_b:=true;
 beep:=true;
 for i:=1 to ParamCount do begin
     par:=paramstr(i);
     if (par='/u') or (par='/U') then text_u_b:=false;
     if (UpCase(par[2])='B') then pocpo:=vali(par);
     if (par='/s') or (par='/S') then beep:=false;
     if (par='/h') or (par='/H') then help;
     if (par='/d') or (par='/D') then default;
    end;
end;
 
{ *** Odkial spustil Videostop *** }
procedure get_cesta;
var i:integer;
begin
 i:=length(cesta);
 while ((i>1) and (cesta[i]<>'\')) do dec(i);
 cesta:=copy(cesta,1,i);
end;
 
BEGIN
 cesta:=paramstr(0);
 get_cesta;
 mous:=init_mys;
 put_mous:=false;
 
 defarby(9);                                    { Aby textovy uvod bolo vydiet }
 get_param;
 zdisku;                                        { *** Bez uvodu *** }
 if text_u_b then text_uvod;
 defkartu;
 
 repeat
  uvod(0);                                      { *** Kazdy uvod nadefinuje aj pocbo *** }
  vyhral(1);
  bodovanie(body);
  pokus:=0;
  ch:=tReadkey;
  if ch=#27 then begin
      closegraph;
      window(1,1,80,25);
      koniec('VideoStop v.3.1','95');
      halt(0);
     end;
 
  kocka(1,cislo,1);kocka(2,cislo,1);kocka(3,cislo,1);
  repeat
   repeat
    clear_keyb;
    get_mys_but;
    kocka((pokus mod 3)+1,cislo,0);
    get_mys_but;
   until tKeyPressed;
   body:=kontrola;
   randomize;
   bodovanie(body);
   pokus:=0;
  until (ch=#27) or (body<1) or (pocpo<1);
 until zaver;
 closegraph;
 window(1,1,80,25);
 koniec('VideoStop v.3.1','95');
END.