Umístnení souboru www.TrSek.com/pas/videostop.pas{ 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;
{ *** 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));
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);
{ *** 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 *** }
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;
{ *** 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.