Umístnení souboru www.TrSek.com/pas/milion.pas

{ MILION.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{ Program napodobnuje hru milionar.                                 }
{ Jednotlive otazky sa definuju v textovych suboroch.               }
{                                                                   }
{ Datum:19.01.2005                            http://www.trsek.com  }

program hra_milionar;
uses crt,dos,graph,mycrt;

const MENA='milion.txt';

      peniaze:array[1..10] of integer=
      (5,10,15,50,75,100,150,300,500,1000);

var grDriver:Integer;
      grMode:Integer;
           q:char;         { stlaceny klaves     }

{ kolko to je korun ma level }
function cena(level:integer):string;
begin
  if(level=0)then
    cena:='0'
  else
    cena:=Cislo(peniaze[level],4)+' 000';
end;

{ vykresli graf vysledkov }
procedure vysledky;
var meno:string;
   level:integer;
       f:text;
       i:integer;
begin
  grDriver := Detect;
  InitGraph(grDriver, grMode,' ');
  outtextxy(140,5,'Vysledkova listina jednotlivych hracov');

  { nakreslime os }
  line(80,18,80,450);

  { nastavime vzor vyplnovania }
  SetFillStyle(SolidFill, Green);

  { zacneme citat subor }
  assign(f,MENA);
  reset(f);
  i:=0;

  { vycitame vsetkych sutaziacich, ale maximalne 24 }
  while(not(eof(f)) and (i<24))do
  begin
    inc(i);
    readln(f,meno);
    readln(f,level);

    { meno hraca }
    outtextxy(5,i*18+6,meno);

    { jeho score }
    bar3d(80,i*18,80+level*55,(i+1)*18,0,TopOff);
    outtextxy(level*55+10,i*18+6,Cena(level));
  end;

  { zatvorime subor }
  close(f);

  { vypiseme spravu }
  outtextxy(140,465,'Pre navrat do menu stlac klaves <Enter>');
  readln;

  { zatvoriem grafiku }
  CloseGraph;
end;

{ vyberie zo suboru jednu otazku a tu vypise }
function VypisOtazku(level:integer):integer;
var f:text;
  otazka:string;
     odp:array[1..4] of string;
     por:array[1..4] of integer;
     x,i:integer;
begin
  { otvorime subor }
  assign(f,'level.'+ Cislo(level,0));
  reset(f);

  { nahodne vygeneruje otazku od 1-3 }
  x:=trunc(random(3));

  { precita subor az po otazku }
  for i:=1 to (x*6)+1 do
     readln(f,otazka);

  { vyprazdni pole poradi otazok }
  for i:=1 to 4 do por[i]:=0;

  { zamiesa odpovede }
  for i:=1 to 4 do begin
    x:=trunc(random(4))+1;

    { najde dalsieho vhodneho kandidata }
    while(por[x]<>0) do begin
      if(por[x]<>0)then x:=x+1;
      if(x>4)then x:=1;
    end;

    { nasiel }
    por[x]:=i
  end;

  { precita mozne odpovede }
  readln(f,odp[por[1]]);
  readln(f,odp[por[2]]);
  readln(f,odp[por[3]]);
  readln(f,odp[por[4]]);

  { zatvorime subor }
  close(f);

  { vypiseme otazku }
  writexy(10,10,otazka);

  { vypiseme odpovede }
  writexy(12,12,'a. '+ odp[1]);
  writexy(12,13,'b. '+ odp[2]);
  writexy(12,14,'c. '+ odp[3]);
  writexy(12,15,'d. '+ odp[4]);
  writexy(10,17,'Stlac a,b,c,d');

  { prva odpoved v subore je vzdy spravna }
  VypisOtazku:=por[1];
end;

{ vyopise ake je skore }
procedure VypisScore(level:integer);
var i:integer;
begin
  writexy(60,6,' Peniaze');
  writexy(60,7,'--------');

  for i:=1 to 10 do begin
    if(i=level)then farba(red,yellow)
               else farba(black,yellow);

    writexy(60,18-i,Cena(i));
  end;

  farba(black,yellow);
end;

{ hra milionar }
procedure milionar;
var odp:integer;
     ch:char;
  level:integer;
   konc:boolean;
   meno:string;
begin
  randomize;
  level:=0;
  konc:=false;

  { opytame sa ako sa vola }
  clrscr;
  write('Zadaj svoje meno:');
  readln(meno);

  repeat
    clrscr;
    writexy(30,2,'VEDOMOSTNY KVIZ');
    writexy(30,4,'hrac:'+meno);
    VypisScore(level);

    odp:=VypisOtazku(level+1);

    { cakaj na klaves }
    ch:=readkey;

    { klavesa ESC konci }
    if(ch=#27)then konc:=true;

    { neuhadol - konci, uhadol - dalsi level }
    if((ord(ch)-ord('a'))<>(odp-1))then
     begin
       konc:=true;
       writexy(10,17,'Zle spravna odpoved je: '+chr(odp+96));
     end
    else
     begin
      inc(level);            { dalsi level }
      VypisScore(level);     { vypis skore }
     end;

    { ak uhadol aj poslednu otazku konci }
    if(level=10)then
       konc:=true;

  until (konc);

  { skore zapiseme do suboru }
  Zapis(MENA,meno,level);

  { este ho nechame nech si to pozrie }
  writexy(10,18,'Vyhral si:'+cena(level)+' Sk');
  writexy(10,20,'Pre navrat do menu stlac klaves <Enter>');
  ch:=readkey;
end;

{ zaciatok programu }
BEGIN

  repeat
    clrscr;

    farba(black,red);
    writexy(26,10,'Ponuka cinnosti:');

    writexy(26,11,'1. Hra Milionar');
    writexy(26,12,'2. Prezriet vysledky');
    writexy(26,13,'3. Koniec');

    q:=readkey;                { precita stlaceni eklavesu }
    if(q='1') then milionar;   { spusti hru     }
    if(q='2') then vysledky;   { ukaze vysledky }

  until(q='3');                { q=3 koniec     }
END.

Copyrigth by Zdeno Sekerak 2007, http://www.trsek.com