Hra pexeso naprogramovaná v pascale

{ PEXESO.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{ Program urceny pre hru pexesa na pocitaci.                        }
{                                                                   }
{ Datum:12.05.2001                             http://www.trsek.com }
 
program pexeso;
uses crt,dos,graph,mys2,menu;
 
const
    n=6;                { pocet kariet v riadku, stplci }
    sirka=90;           { sirka karty           }
    vyska=60;           { vyska karty           }
    medzera=10;         { medzera medzi kartami }
 
    { 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);
 
    setcolor(white);
    moveto(x,y);
    lineto(x,y+vyska);
    lineto(x+sirka,y+vyska);
    lineto(x+sirka,y);
    lineto(x,y);
 
    setfillstyle(3,1);
    floodfill(x+1,y+1,white);
end;
 
 
{ 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;
 
    setcolor(white);
    moveto(x,y);
    lineto(x,y+vyska);
    lineto(x+sirka,y+vyska);
    lineto(x+sirka,y);
    lineto(x,y);
 
    setfillstyle(1,red);
    floodfill(x+1,y+1,white);
    settextstyle(0,0,0);
 
    { vypis text }
    xt:=round((sirka-TextWidth(a[xp,yp].meno))/2);
    yt:=round((vyska-TextHeight(a[xp,yp].meno))/2);
    outtextxy(x+xt, y+yt, a[xp,yp].meno);
end;
 
 
{ vykresli pexeso }
procedure vykresli;
begin
    cancel_mys;
    setcolor(yellow);
    setbkcolor(black);
    cleardevice;
 
    { 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;
 
    h:=trunc(a[x,y].time/3600);
    m:=trunc((a[x,y].time-(h*3600))/60);
    s:=a[x,y].time-(h*3600)-(m*60);
 
    outtextxy( 50, por*(TextHeight('A')+5)+60, s1(por)+'. '+a[x,y].meno);
    outtextxy(200, por*(TextHeight('A')+5)+60, s1(h)+':'+s1(m)+':'+s1(s));
end;
 
 
{ 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;
 
              until ((ch=#27) or (ch=#13));
 
              CloseGraph;
 
          end;      { 1:begin }
 
     end;           { case }
END.