Umístnení souboru www.TrSek.com/pas/pexeso.pas{ PEXESO.PAS Copyright (c) TrSek alias Zdeno Sekerak }
{ Program urceny pre hru pexesa na pocitaci. }
{ }
{ Datum:12.05.2001 http://www.trsek.com }
{ zoznam mien na kartach }
d_meno:array[1..18] of string=
('I.Fedorov', 'M.Zieman', 'P.Clooney', 'M.Slovak', 'I.Tasler', 'J.Bougard',
'J.Kuzmisin', 'K.Christian', 'P.Osczyk', 'L.Hawk', 'H.Swenson', 'D.Carlsberg',
'O.Mivrov', 'G.Guiness', 'J.Okynava', 'I.Hatterson', 'Z.Freud', 'J.Carlos');
type zaznam=record
meno:string; { meno na karte }
najdene:boolean; { ci je karta otacena ako najdena }
poradie:integer; { v akom poradi bola najdena }
time:longint; { za aky cas v sekundach bola najdena }
end;
var
a:array[1..n,1..n] of zaznam;
x,y,i,j,gd,gm:integer;
pocet_kliknuti:0..2;
uz_x,uz_y:integer;
stlacena:boolean;
poradie:integer;
zac_hodin:longint;
x0,y0:integer; { suradnice zlava, zhora aby bolo pexeso v strede }
ch:char; { stlacenie klavesy }
{ b:array[1..n] of 0..n;
c:array[1..n,1..n] of 0..n;
cislo:integer;
dobre:boolean;}
{ urobi z cisla string }
function s1(i:longint):string;
var s:string;
begin
str(i,s);
if i<=9 then s:='0'+s;
s1:=s;
end;
{ nakresli neodkrytu kartu }
procedure nakresli_neodkryte(xp,yp:integer);
var x,y:integer;
begin
x:=(xp-1)*(sirka+medzera)+x0;
y:=(yp-1)*(vyska+medzera)+y0;
setfillstyle(1,black);
setcolor(black);
Bar(x, y, x+sirka, y+vyska);
{ nakresli odkrytu kartu }
procedure nakresli_odkryte(xp,yp:integer);
var x,y:integer;
xt,yt:integer;
begin
x:=(xp-1)*(sirka+medzera)+x0;
y:=(yp-1)*(vyska+medzera)+y0;
{ zisti nulove body }
x0:=round((GetMaxX-(n*(sirka+medzera)))/2);
y0:=round((GetMaxY-(n*(vyska+medzera)))/2);
for i:=1 to n do
for j:=1 to n do begin
if a[i,j].najdene=false then
nakresli_neodkryte(i,j)
else
nakresli_odkryte(i,j);
end;
outtextxy(x0,getmaxy-TextHeight('A')-5,'ESC - Koniec, V - Vysledkova listina');
show_mys;
end;
{ pip ak uhadne 1, ak nie 2 }
procedure pip(ako:integer);
begin
if ako=1 then sound(800);
if ako=2 then sound(4000);
delay(200);
nosound;
end;
{ zisti aktualny cas v sekundach }
function celkom_sekund:longint;
var h,m,s,ss:word;
celkom:longint;
begin
gettime(h,m,s,ss);
celkom:=h;
celkom_sekund:=(celkom*3600)+(m*60)+s;
end;
{ zisti ci nasiel dve rovnake karty }
procedure zisti;
var x,y,x1,y1:integer;
begin
where_is_mys(x1,y1);
{ kde je kurzor mysi }
x:=trunc((x1-x0)/(sirka+medzera))+1;
y:=trunc((y1-y0)/(vyska+medzera))+1;
{ je totalne mimo !!! }
if x<1 then x:=1;
if y<1 then x:=1;
if x>n then x:=n;
if y>n then x:=n;
{ klikol inam ??? }
if ((x<>uz_x) or (y<>uz_y)) and (a[x,y].najdene=false) then
begin
cancel_mys;
nakresli_odkryte(x,y);
show_mys;
{ klikol na druhu kartu }
if (uz_x<>0) and (uz_y<>0) then
begin
{ nasiel zhodne ??? }
if a[uz_x,uz_y].meno = a[x,y].meno then
begin
a[uz_x,uz_y].najdene:=true;
a[x,y].najdene:=true;
{ zapis najdenie a ostatne }
poradie:=poradie+1;
a[x,y].poradie:=poradie;
a[x,y].time:=celkom_sekund-zac_hodin;
a[uz_x,uz_y].poradie:=poradie;
a[uz_x,uz_y].time:=a[x,y].time;
pip(1);
end else
{ neuhadol }
begin
pip(2);
delay(700);
cancel_mys;
nakresli_neodkryte(x,y);
nakresli_neodkryte(uz_x,uz_y);
show_mys;
end;
{ zhuluj pre dalsiu kartu }
uz_x:=0;
uz_y:=0;
end else
if a[x,y].najdene=false then
begin
uz_x:=x;
uz_y:=y;
end;
end;
end;
{ otestuje ci je mozne kartu na toto miesto }
procedure otestuj(var x,y:integer);
begin
while( a[x,y].meno<>'' ) do
begin
x:=x+1;
if x>n then begin x:=1; y:=y+1; end;
if y>n then begin x:=1; y:=1; end;
end;
end;
{ zamiesa karty }
procedure zamiesaj;
var x,y:integer;
begin
{ nastav na prazdne }
for i:=1 to n do
for j:=1 to n do
a[i,j].meno:='';
randomize;
for i:=1 to 18 do
begin
{ prva karta }
x:=random(5)+1;
y:=random(5)+1;
otestuj(x,y);
a[x,y].meno:=d_meno[i];
{ druha karta }
x:=random(5)+1;
y:=random(5)+1;
otestuj(x,y);
a[x,y].meno:=d_meno[i];
end;
end;
{ nastavi default hodnoty }
procedure nastav_zaciatok;
begin
poradie:=0;
pocet_kliknuti:=0;
uz_x:=0;
uz_y:=0;
ch:=#0;
{ nastav ze su neodkryte }
for i:=1 to n do
for j:=1 to n do
a[i,j].najdene:=false;
{ kolko je hodin }
zac_hodin:=celkom_sekund;
end;
{ vypisuje meno do vysledkovej listiny }
procedure vypis_meno(x,y:integer);
var h,m,s:longint;
por:integer;
begin
por:=a[x,y].poradie;
{ zobrazi vysledky a pocka na stlacenie klavesy }
procedure vysledky;
var x,y,i:integer;
begin
cancel_mys;
setcolor(yellow);
setbkcolor(black);
cleardevice;
outtextxy(50,50,'Vyslekova listina');
for i:=1 to poradie do
begin
for x:=1 to n do
for y:=1 to n do
if a[x,y].poradie=i then
begin
vypis_meno(x,y);
x:=n;y:=n;
end;
end;
show_mys;
repeat until keypressed;
end;
{ zisti ci existuje subor }
procedure test(subor:string);
var f:text;
begin
assign(f, subor);
{$I-}
Reset(f);
{$I-}
if( IOResult<>0 )then begin
writeln('Subor ',subor,' neexistuje. Nemozem pokracovat.');
readln;
end;
Close(f);
end;
{ Hlavne begin }
BEGIN
test('menu.mnu');
case zobraz_menu('menu.mnu',1,1) of
1:begin
nastav_zaciatok;
zamiesaj;
detectgraph(gd,gm);
initgraph(gd,gm,'');
vykresli;
{ reset_mys;}
show_mys;
stlacena:=false;
repeat
reset_stisku;
stlacena:=left;
if stlacena then zisti;
if keypressed then
begin
ch:=readkey;
if (ch='v') or (ch='V') then
begin
vysledky;
vykresli;
end;
end;