Game Videostop in pascal like TV show

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Category: Source in Pascal
videostop.pngProgram: Videostop.pas
File exe: Videostop.exe
need: Anicka.bmpVideo.dat

The origin of this program can be traced to the game which used to be played in a well-known Czech televised competition called Videostop with Jan Rosák as its presenter. It's full of tricks. To name just a few of them All in all, it looks superb. All the essential stuff without which this game is unimaginable, like prizes, counting of the number of points and speed, can be read out of the video.dat file, if it exists. Otherwise, it is operated by the predefined values.

Parameters of run programs
/h - help
/u - without introduction
/s - without sound
/b20 - 20 choice
/d - make file with victory Video.dat
{ 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.