Jsi vrchním radcem panovnika ve starovekém Egypte Ramesse II

{ pyramida.pas                          Copyright (c) Petr Masopust  }
{ Hra na stavbu pyramidy pro Ramesse II.                             }
{                                                                    }
{ Datum:03.09.2018                              http://www.trsek.com }
uses univgraf,software,oknaunit,show_pcx,endturnu,crt,dos;
var o1,pyramida:okno;
    exepath:dirstr;
    znova:boolean;
    prov:jednaprovincie;
    hp:byte;
    volnychlidi,volnychotroku:longint;
    {m:menuitems;}
 
function IntToStr(I: integer): String;
var
  S: string[11];
begin
  Str(I, S);
  IntToStr := S;
end;
 
{$F+}
procedure myerror(s:string);far;
begin
  sound(1000);delay(100);nosound;
  rok:=30;
  dotazok(s,2);
end;
 
procedure zazrakobr(s:string);far;
var m:menuitems;
    i,pocet,mini:byte;
begin
  sound(1000);delay(100);nosound;
  i:=0;
  mini:=1;
  pocet:=0;
  repeat
    inc(i);
    if s[i] = #13 then begin
      m[pocet]:=copy(s,mini,i-mini);
      inc(i);
      inc(pocet);
      mini:=i;
    end;
  until i>length(s);
  m[pocet]:=copy(s,mini,length(s)-mini+1);
  m[pocet+1]:=terminator;
  dotazviceok(m,2);
end;
{$F-}
 
procedure clearta;assembler;
asm
  mov ah,0ch
  mov al,6
  mov dl,0ffh
  int 21h
end;
 
procedure help;
var mhelp:menuitems;
begin
  mhelp[0]:='Jsi vrchnim radcem panovnika ve';
  mhelp[1]:='starovekem Egypte Ramesse II.';
  mhelp[2]:='Panovnik te poveril stavbou jeho';
  mhelp[3]:='pyramidy. Muzes si vybrat 1 z 8';
  mhelp[4]:='provincii, ktere budes vladnout.';
  mhelp[5]:='Na stavbu pyramidy mas jen 20';
  mhelp[6]:='let. Necht se ti stavba podari !';
  mhelp[7]:=terminator;
  dotazviceok(mhelp,2);
 
  mhelp[0]:='V provincii mas urcity pocet oby-';
  mhelp[1]:='vatel a otroku. Na polich a pyra-';
  mhelp[2]:='mide pracuji otroci lepe nez oby-';
  mhelp[3]:='vatele a naopak penize vydelavaji';
  mhelp[4]:='obyvatele lepe nez otroci. Prace';
  mhelp[5]:='se zefektivni, kdyz se pouzivaji';
  mhelp[6]:='nastroje, a to az dvojnasobne.';
  mhelp[7]:='Pole, sypky a otroci se daji na';
  mhelp[8]:='trhu nakoupit i prodat.';
  mhelp[9]:=terminator;
  dotazviceok(mhelp,2);
 
  mhelp[0]:='Univerzalni cenik:';
  mhelp[1]:='';
  mhelp[2]:='1 pole stoji 10 tragu';
  mhelp[3]:='1 sypka stoji 5 tragu';
  mhelp[4]:='1 nastroj stoji 3 tragy';
  mhelp[5]:='1 otrok stoji 1 trag';
  mhelp[6]:='';
  mhelp[7]:='Trag je fiktivni menova jednotka';
  mhelp[8]:='(kurs ke Kc je neznamy).';
  mhelp[9]:=terminator;
  dotazviceok(mhelp,2);
 
  mhelp[0]:='Par rad do zacatku:';
  mhelp[1]:='';
  mhelp[2]:='Z 1 pole je obili do 2 sypek.';
  mhelp[3]:='Z 1 sypky se naji 5 lidi.';
  mhelp[4]:='10 lidi vydela 1 trag.';
  mhelp[5]:='1000 lidi postavi 1 stupen py-';
  mhelp[6]:='ramidy.';
  mhelp[7]:='Kazda zeme ma male rozdily ve';
  mhelp[8]:='vyrobe, ale nejvyraznejsi ma';
  mhelp[9]:='Superbus - odvrhl otroctvi.';
  mhelp[10]:=terminator;
  dotazviceok(mhelp,2);
 
  mhelp[0]:='Vyhlidky do budoucna:';
  mhelp[1]:='';
  mhelp[2]:='Zmena rozliseni na 640 x 480.';
  mhelp[3]:='Misto statickeho obrazku v';
  mhelp[4]:='pozadi animace.';
  mhelp[5]:='Ovladani bude mozne i mysi.';
  mhelp[6]:=terminator;
  dotazviceok(mhelp,2);
 
  mhelp[0]:='Pokud ma nekdo pripominky';
  mhelp[1]:='nebo dotazy necht napise';
  mhelp[2]:='na adresu:';
  mhelp[3]:='';
  mhelp[4]:='Petr Masopust';
  mhelp[5]:='Safarikova 124';
  mhelp[6]:='Chomutov';
  mhelp[7]:='430 03';
  mhelp[8]:=terminator;
  dotazviceok(mhelp,2);
 
  mhelp[0]:='Jestlize se nekomu hra';
  mhelp[1]:='libi a chce podporit';
  mhelp[2]:='dalsi vyvoj, necht posle';
  mhelp[3]:='financni prispevek dle';
  mhelp[4]:='sveho uvazeni na vyse';
  mhelp[5]:='uvedenou adresu.';
  mhelp[6]:=terminator;
  dotazviceok(mhelp,2);
end;
 
function fexist(s:string):boolean;
var
    dirinfo: SearchRec;
begin
  FindFirst(s,Anyfile,dirinfo);
  if doserror = 0 then fexist:=true
  else fexist:=false;
end;
 
procedure zapis(i:byte);
var f:file of saveload;
    p:saveload;
begin
  assign(f,exepath+'\save'+inttostr(i)+'.pyr');
  save(p);
  {$I-}
  rewrite(f);
  if ioresult <> 0 then myerror('Nelze otevrit soubor !');
  write(f,p);
  if ioresult <> 0 then myerror('Nelze zapsat do souboru !');
  close(f);
  if ioresult <> 0 then myerror('Nelze uzavrit soubor !');
  {$I+}
end;
 
procedure savefile(i:byte);
begin
  if fexist(exepath+'\save'+inttostr(i)+'.pyr') then begin
    if dotaz(o1,'Soubor existuje, prepsat ?',8,2,false) then zapis(i);
  end else zapis(i);
end;
 
procedure savehru;
var i,max:byte;
    f:file of saveload;
    s:saveload;
    msave:menuitems;
    savename:string;
 
begin
  max:=0;
  for i:=0 to 7 do begin
    savename:='save'+inttostr(i)+'.pyr';
    if fexist(exepath+savename) then begin
      assign(f,exepath+'\save'+inttostr(i)+'.pyr');
      {$I-}
      reset(f);
      if ioresult <> 0 then myerror('Nelze otevrit soubor !');
      read(f,s);
      if ioresult <> 0 then myerror('Nelze cist ze souboru !');
      close(f);
      if ioresult <> 0 then myerror('Nelze uzavrit soubor !');
      {$I+}
      msave[i]:=s.jmeno;
      if length(msave[i])>max then max:=length(msave[i]);
    end else msave[i]:='Volno';
  end;
  msave[8]:=volno;
  msave[9]:='Zpet';
  msave[10]:=terminator;
  center(o1,max);
  i:=menu(o1,msave,19,1,10)-1;
  if i<>8 then savefile(i);
end;
 
procedure loadfile(i:byte);
var f:file of saveload;
    p:saveload;
begin
  assign(f,exepath+'save'+inttostr(i)+'.pyr');
  {$I-}
  reset(f);
  if ioresult <> 0 then myerror('Nelze otevrit soubor !');
  read(f,p);
  if ioresult <> 0 then myerror('Nelze cist ze souboru !');
  close(f);
  if ioresult <> 0 then myerror('Nelze uzavrit soubor !');
  {$I+}
  load(p,prov);
end;
 
function loadhru:boolean;
var i,max:byte;
    f:file of saveload;
    s:saveload;
    mload:menuitems;
    savename:string;
begin
  max:=0;
  for i:=0 to 7 do begin
    savename:='\save'+inttostr(i)+'.pyr';
    if fexist(exepath+savename) then begin
      assign(f,exepath+'\save'+inttostr(i)+'.pyr');
      {$I-}
      reset(f);
      if ioresult <> 0 then myerror('Nelze otevrit soubor !');
      read(f,s);
      if ioresult <> 0 then myerror('Nelze cist ze souboru !');
      close(f);
      if ioresult <> 0 then myerror('Nelze uzavrit soubor !');
      {$I+}
      mload[i]:=s.jmeno;
      if length(mload[i]) > max then max:=length(mload[i]);
    end else mload[i]:='Volno';
  end;
  mload[8]:=volno;
  mload[9]:='Zpet';
  mload[10]:=terminator;
  center(o1,max);
  repeat
    i:=menu(o1,mload,19,1,10)-1;
  until (mload[i]<>'Volno') or (i=8);
  if i<8 then begin
    loadfile(i);
    loadhru:=true;
  end else loadhru:=false;
end;
 
procedure konec;
begin
  if dotaz(o1,' Opravdu skoncit ?',8,2,false) then begin
    oknoclose(pyramida);
    donegraph;
    halt(0);
  end;
end;
 
procedure new;
var canexit:boolean;
    mnew:menuitems;
begin
  canexit:=false;
  mnew[0]:='Kuk-al-Challi';
  mnew[1]:='Superbus';
  mnew[2]:='Koronuta';
  mnew[3]:='Bigpolis';
  mnew[4]:='DJ polis';
  mnew[5]:='Svopakov';
  mnew[6]:='IQ polis';
  mnew[7]:='Killpolis';
  mnew[8]:=volno;
  mnew[9]:='Help';
  mnew[10]:=terminator;
  center(o1,length(mnew[0]));
  repeat
  case menu(o1,mnew,19,1,10) of
    9: help;
    1..8:  begin
             hp:=round(exp(ln(2)*(hp-1)));
             canexit:=true;
           end;
  end;
  until canexit;
  o1.x1:=40;
  repeat
    jmeno:=inputline(o1,2,10,'Zadej sve jmeno, spravce:');
  until jmeno <> '';
  newgame(prov);
end;
 
Function GetKey : char;
var
  Key : char;
begin
  ClearTA;
  repeat until KeyPressed; { cekej na stisk libovolne klavesy }
  Key := ReadKey;   { precti znak z klavesnice }
  if (Key = #0) and KeyPressed then begin
    Key := ReadKey;{ precti druhy byte kodu klavesy }
    Key := Chr(Ord(Key)+128);
  end;
  GetKey := Key;
end;
 
function GetLegalKey(LegalSet : CharSet) : char;
var
  Key : char;
begin
  repeat
    Key := GetKey;     { cekej na vstup z klavesnice}
  until Key in LegalSet;{ patri znak do mnoziny ? }
  GetLegalKey := Key;
end;
 
{    lidinapolich,lidinanastrojich,lidinapyramide,lidinapenize:word;
    otrokunapolich,otrokunanastrojich,otrokunapyramide,otrokunapenize:word;
    procedure assignokno(var o:okno;x1,y1,x2,y2:integer;barva,barvaramecku,krok:byte);
 }
 
procedure fillbar(x,y,x1,y1:integer;c:byte);
var px,py:integer;
begin
  for px:=x to x1 do for py:=y to y1 do putpixel(px,py,c);
end;
 
var t:real;
    ko:word;
procedure pridej(var co,odkud:longint;kolika,kolikb:integer;b:boolean);
begin
  if onetime-t<=0.1 then inc(ko)
  else ko:=1;
  t:=onetime;
  if b and (ko * kolikb > odkud)then ko:=1;
  inc(co,ko*kolika);
  dec(odkud,ko*kolikb);
end;
 
var mv,mp,ms,mn,mo:byte;
 
procedure prepisnakup(def:byte;volnych:integer);
var i:byte;
begin
  if length(inttostr(volnych)) < mv then fillbar(15*8,8*8,30*8,8*8+8,16);
  if length(inttostr(prov.pole)) < mp then fillbar(16*8,9*8,30*8,9*8+8,16);
  if length(inttostr(prov.sypky)) < ms then fillbar(17*8,80,30*8,10*8+8,16);
  if length(inttostr(prov.nastroje)) < mn then fillbar(20*8,88,30*8,11*8+8,16);
  if length(inttostr(prov.otroci)) < mo then fillbar(17*8,12*8,30*8,12*8+8,16);
  mv:=length(inttostr(volnych));
  mp:=length(inttostr(prov.pole));
  ms:=length(inttostr(prov.sypky));
  mn:=length(inttostr(prov.nastroje));
  mo:=length(inttostr(prov.otroci));
    {  (s: string;cp,cz,x,y: byte);}
  gwrite('Penize: '+inttostr(volnych),16,2,7,8);
  if def=0 then i:=2 else i:=20;
  gwrite('1. Pole: '+inttostr(prov.pole),16,i,7,9);
  if def=1 then i:=2 else i:=20;
  gwrite('2. Sypky: '+inttostr(prov.sypky),16,i,7,10);
 
  if def=2 then i:=2 else i:=20;
  gwrite('3. Nastroje: '+inttostr(prov.nastroje),16,i,7,11);
 
  if def=3 then i:=2 else i:=20;
  gwrite('4. Otroci: '+inttostr(prov.otroci),16,i,7,12);
 
  if def=4 then i:=2 else i:=20;
  gwrite('5. Hlavni menu',16,i,7,14);
end;
 
 
procedure nakup;
var m:menuitems;
    volnych:longint;
    o:okno;
    i:byte;
    canexit:boolean;
    c,j:char;
begin
  i:=0;
  assignokno(o,6*8,7*8,31*8,16*8,16,19,8);
  oknoopen(o);
  if prov.penize=-1 then prov.penize:=0;
  prepisnakup(i,prov.penize);
  canexit:=false;
  repeat
  j:=getlegalkey(['1'..'5',up,down,pgup,pgdown,left,right,cr]);
  case j of
  pgup:i:=0;
  pgdown:i:=4;
  up: if i=0 then i:=4 else dec(i);
  down: if i=4 then i:=0 else inc(i);
  left: begin
          if i<4then
          case i of
          0: if prov.pole>0 then pridej(prov.penize,prov.pole,10,1,true);
{               dec(prov.pole);
               inc(prov.penize,10);
             end;
 }         1: if prov.sypky>0 then pridej(prov.penize,prov.sypky,5,1,true);
 {              dec(prov.sypky);
               inc(prov.penize,5);
             end;
  }        2: if prov.nastroje>0 then pridej(prov.penize,prov.nastroje,3,1,true);
  {             dec(prov.nastroje);
               inc(prov.penize,3);
             end;
   }       3: if prov.otroci>0 then pridej(prov.penize,prov.otroci,1,1,true);
{               dec(prov.otroci);
               inc(prov.penize);
             end;
 }         end;
        end;
  right: begin
          if i<4then
          case i of
          0: if prov.penize>=10 then pridej(prov.pole,prov.penize,1,10,true);
  {             inc(prov.pole);
               dec(prov.penize,10);
             end;
   }       1: if prov.penize>=5 then pridej(prov.sypky,prov.penize,1,5,true);
  {             inc(prov.sypky);
               dec(prov.penize,5);
             end;
   }       2: if prov.penize>=3 then pridej(prov.nastroje,prov.penize,1,3,true);
    {           inc(prov.nastroje);
               dec(prov.penize,3);
             end;
     }     3: if prov.penize>=1 then pridej(prov.otroci,prov.penize,1,1,true);
      {         inc(prov.otroci);
               dec(prov.penize);
             end;
       }   end;
        end;
  cr: if i=4 then canexit:=true;
  '5': begin
         i:=4;
         canexit:=true;
       end;
  '1'..'4':i:=ord(j)-49;
  end;
  prepisnakup(i,prov.penize);
  until canexit;
  oknoclose(o);
end;
 
var lb,lp,ln,ly,le:byte;
procedure prepislidi(def:byte;volnych:integer);
var i:byte;
begin
  if length(inttostr(volnych)) <lb then fillbar(26*8,8*8,30*8,8*8+8,16);
  if length(inttostr(lidinapolich)) <lp then fillbar(21*8,9*8,30*8,9*8+8,16);
  if length(inttostr(lidinanastrojich)) <ln then fillbar(25*8,80,30*8,10*8+8,16);
  if length(inttostr(lidinapyramide)) <ly then fillbar(23*8,88,30*8,11*8+8,16);
  if length(inttostr(lidinapenize)) <le then fillbar(23*8,12*8,30*8,12*8+8,16);
  lb:=length(inttostr(volnych));
  lp:=length(inttostr(lidinapolich));
  ln:=length(inttostr(lidinanastrojich));
  ly:=length(inttostr(lidinapyramide));
  le:=length(inttostr(lidinapenize));
    {  (s: string;cp,cz,x,y: byte);}
  gwrite('Poddani bez prace: '+inttostr(volnych),16,2,7,8);
  if def=0 then i:=2 else i:=20;
  gwrite('1. Na polich: '+inttostr(lidinapolich),16,i,7,9);
  if def=1 then i:=2 else i:=20;
  gwrite('2. Na nastrojich: '+inttostr(lidinanastrojich),16,i,7,10);
  if def=2 then i:=2 else i:=20;
  gwrite('3. Na pyramide: '+inttostr(lidinapyramide),16,i,7,11);
  if def=3 then i:=2 else i:=20;
  gwrite('4. Na penezich: '+inttostr(lidinapenize),16,i,7,12);
  if def=4 then i:=2 else i:=20;
  gwrite('5. Hlavni menu',16,i,7,14);
end;
 
 
procedure poddani;
var m:menuitems;
    volnych:longint;
    o:okno;
    i:byte;
    canexit:boolean;
    c,j:char;
begin
  i:=0;
  assignokno(o,6*8,7*8,31*8,16*8,16,19,8);
  oknoopen(o);
  prepislidi(i,volnychlidi);
  canexit:=false;
  repeat
  j:=getlegalkey(['1'..'5',up,down,pgup,pgdown,left,right,cr]);
  case j of
  up: if i=0 then i:=4 else dec(i);
  down: if i=4 then i:=0 else inc(i);
  pgup:i:=0;
  pgdown:i:=4;
  left: if volnychlidi<=prov.lidi then begin
          case i of
          0: if lidinapolich>0 then pridej(volnychlidi,lidinapolich,1,1,true);
{                dec(lidinapolich);
                inc(volnychlidi);
              end;
 }         1: if lidinanastrojich>0 then pridej(volnychlidi,lidinanastrojich,1,1,true);
  {              dec(lidinanastrojich);
                inc(volnychlidi);
              end;
   }       2: if lidinapyramide>0 then pridej(volnychlidi,lidinapyramide,1,1,true);
    {            dec(lidinapyramide);
                inc(volnychlidi);
              end;
     }     3: if lidinapenize>0 then pridej(volnychlidi,lidinapenize,1,1,true);
      {          dec(lidinapenize);
                inc(volnychlidi);
              end;
       }   end;
        end;
  right:if (volnychlidi<=prov.lidi) and (volnychlidi>0) then begin
          if i<4then
          case i of
          0: if lidinapolich+otrokunapolich<= prov.pole*2-1 then pridej(lidinapolich,volnychlidi,1,1,true);
          1: pridej(lidinanastrojich,volnychlidi,1,1,true);
          2: pridej(lidinapyramide,volnychlidi,1,1,true);
          3: pridej(lidinapenize,volnychlidi,1,1,true);
          end;
        end;
  cr: if i=4 then canexit:=true;
  '5': begin
         i:=4;
         canexit:=true;
       end;
  '1'..'4':i:=ord(j)-49;
  end;
  prepislidi(i,volnychlidi);
  until canexit;
  oknoclose(o);
end;
 
var ov,op,on,oy,oe:byte;
procedure prepisotroku(def:byte;volnych:integer);
var i:byte;
begin
  if length(inttostr(volnych)) <ov then fillbar(25*8,8*8,30*8,8*8+8,16);
  if length(inttostr(otrokunapolich)) <op then fillbar(21*8,9*8,30*8,9*8+8,16);
  if length(inttostr(otrokunanastrojich)) <on then fillbar(25*8,80,30*8,10*8+8,16);
  if length(inttostr(otrokunapyramide)) <oy then fillbar(22*8,88,30*8,11*8+8,16);
  if length(inttostr(otrokunapenize)) <oe then fillbar(22*8,12*8,30*8,12*8+8,16);
  ov:=length(inttostr(volnych));
  op:=length(inttostr(otrokunapolich));
  on:=length(inttostr(otrokunanastrojich));
  oy:=length(inttostr(otrokunapyramide));
  oe:=length(inttostr(otrokunapenize));
    {  (s: string;cp,cz,x,y: byte);}
  gwrite('Otroku bez prace: '+inttostr(volnych),16,2,7,8);
  if def=0 then i:=2 else i:=20;
  gwrite('1. Na polich: '+inttostr(otrokunapolich),16,i,7,9);
  if def=1 then i:=2 else i:=20;
  gwrite('2. Na nastrojich: '+inttostr(otrokunanastrojich),16,i,7,10);
  if def=2 then i:=2 else i:=20;
  gwrite('3. Na pyramide: '+inttostr(otrokunapyramide),16,i,7,11);
  if def=3 then i:=2 else i:=20;
  gwrite('4. Na penezich: '+inttostr(otrokunapenize),16,i,7,12);
  if def=4 then i:=2 else i:=20;
  gwrite('5. Hlavni menu',16,i,7,14);
end;
 
 
procedure otroci;
var m:menuitems;
    o:okno;
    i:byte;
    canexit:boolean;
    c,j:char;
begin
  i:=0;
  assignokno(o,6*8,7*8,31*8,16*8,16,19,8);
  oknoopen(o);
  prepisotroku(i,volnychotroku);
  canexit:=false;
  repeat
  j:=getlegalkey(['1'..'5',up,down,pgup,pgdown,left,right,cr]);
  case j of
  up: if i=0 then i:=4 else dec(i);
  down: if i=4 then i:=0 else inc(i);
  pgup:i:=0;
  pgdown:i:=4;
  left: if volnychotroku<=prov.otroci then begin
          case i of
          0: if otrokunapolich>0 then pridej(volnychotroku,otrokunapolich,1,1,true);
{               dec(otrokunapolich);
               inc(volnychotroku);
             end;
 }         1: if otrokunanastrojich>0 then pridej(volnychotroku,otrokunanastrojich,1,1,true);
  {             dec(otrokunanastrojich);
               inc(volnychotroku);
             end;
   }       2: if otrokunapyramide>0 then pridej(volnychotroku,otrokunapyramide,1,1,true);
    {           dec(otrokunapyramide);
               inc(volnychotroku);
             end;
     }     3: if otrokunapenize>0 then pridej(volnychotroku,otrokunapenize,1,1,true);
      {         dec(otrokunapenize);
               inc(volnychotroku);
             end;
       }   end;
        end;
  right:if (volnychotroku<=prov.otroci) and (volnychotroku>0) then begin
          if i<4then
          case i of
          0: if otrokunapolich+lidinapolich<=prov.pole*2-1 then pridej(otrokunapolich,volnychotroku,1,1,true);
          1: pridej(otrokunanastrojich,volnychotroku,1,1,true);
          2: pridej(otrokunapyramide,volnychotroku,1,1,true);
          3: pridej(otrokunapenize,volnychotroku,1,1,true);
          end;
        end;
  cr: if i=4 then canexit:=true;
  '5': begin
         i:=4;
         canexit:=true;
       end;
  '1'..'4':i:=ord(j)-49;
  end;
  prepisotroku(i,volnychotroku);
  until canexit;
  oknoclose(o);
end;
 
procedure statusprov;
var m:menuitems;
    i:integer;
begin
  m[0]:=inttostr(rok)+'. rok';
  m[1]:=linka;
  if prov.lidi<0 then i:=0 else i:=prov.lidi;
  m[2]:='V provincii je nyni '+inttostr(i)+' lidi.';
  if prov.pole<0 then i:=0 else i:=prov.pole;
  m[3]:='Mas k dispozici '+inttostr(i)+' poli.';
  if prov.sypky<0 then i:=0 else i:=prov.sypky;
  m[4]:='Mas k dispozici '+inttostr(i)+' sypek obili.';
  if prov.penize<0 then i:=0 else i:=prov.penize;
  m[5]:='Tvoji lide vydelali '+inttostr(i)+' tragu.';
  if prov.nastroje<0 then i:=0 else i:=prov.nastroje;
  m[6]:='Mas k dispozici '+inttostr(i)+' nastroju.';
  if prov.otroci<0 then i:=0 else i:=prov.otroci;
  m[7]:='Mas k dispozici '+inttostr(i)+' otroku.';
  m[8]:='Tvoji lide postavili '+inttostr(round(prov.stupnu))+' stupnu';
  m[9]:='pyramidy.';
  m[10]:=terminator;
  dotazviceok(m,2);
end;
 
procedure opravlidi;
var doplnek:integer;
begin
  doplnek:=volnychlidi+lidinapolich+lidinapyramide+lidinanastrojich+lidinapenize-prov.lidi;
  if doplnek<0 then volnychlidi:=volnychlidi-doplnek
  else if doplnek>0 then begin
    if volnychlidi>=doplnek then dec(volnychlidi,doplnek)
    else begin
      dec(doplnek,volnychlidi);
      volnychlidi:=0;
      if lidinapenize>=doplnek then dec(lidinapenize,doplnek)
      else begin
        dec(doplnek,lidinapenize);
        lidinapenize:=0;
        if lidinapyramide>=doplnek then dec(lidinapyramide,doplnek)
        else begin
          dec(doplnek,lidinapyramide);
          lidinapyramide:=0;
          if lidinanastrojich>=doplnek then dec(lidinanastrojich,doplnek)
          else begin
            dec(doplnek,lidinanastrojich);
            lidinanastrojich:=0;
            if lidinapolich>=doplnek then dec(lidinapolich,doplnek)
            else begin
              dec(doplnek,lidinapolich);
              lidinapolich:=0;
              if doplnek>0 then myerror('Vymrela provincie !');
            end;
          end;
        end;
      end;
    end;
  end;
end;
 
procedure opravotroky;
var doplnek:integer;
begin
  doplnek:=volnychotroku+otrokunapolich+otrokunapyramide+otrokunanastrojich+otrokunapenize-prov.otroci;
  if doplnek<0 then volnychotroku:=volnychotroku-doplnek
  else if doplnek>0 then begin
    if volnychotroku>=doplnek then dec(volnychotroku,doplnek)
    else begin
      dec(doplnek,volnychotroku);
      volnychotroku:=0;
      if otrokunapenize>=doplnek then dec(otrokunapenize,doplnek)
      else begin
        dec(doplnek,otrokunapenize);
        otrokunapenize:=0;
        if otrokunapyramide>=doplnek then dec(otrokunapyramide,doplnek)
        else begin
          dec(doplnek,otrokunapyramide);
          otrokunapyramide:=0;
          if otrokunanastrojich>=doplnek then dec(otrokunanastrojich,doplnek)
          else begin
            dec(doplnek,otrokunanastrojich);
            otrokunanastrojich:=0;
            if otrokunapolich>=doplnek then dec(otrokunapolich,doplnek)
            else begin
              dec(doplnek,otrokunapolich);
              otrokunapolich:=0;
              if doplnek>0 then if znova then begin
                dotazok('Vymreli otroci !',2);
                znova:=false;
              end;
            end;
          end;
        end;
      end;
    end;
  end;
end;
 
procedure zaver;
var mz:menuitems;
begin
  mz[0]:='Podarilo se Ti';
  mz[1]:='dostavet pyramidu';
  mz[2]:='v terminu, faraon';
  mz[3]:='Te zahrnul mnoha';
  mz[4]:='poctami, z nichz';
  mz[5]:='nejvetsi byl slib,';
  mz[6]:='ze budes pochovan';
  mz[7]:='v jeho pyramide,';
  mz[8]:='kterou jsi sam';
  mz[9]:='postavil.';
  mz[10]:=terminator;
  zprava(mz,2,20);
  mz[0]:='Necht zije spravce '+jmeno+' !';
  mz[1]:=volno;
  mz[2]:='Hodne stesti do dalsi hry';
  mz[3]:='preji autori.';
  mz[4]:=volno;
  mz[5]:='Teste se na dalsi verzi !';
  mz[6]:=terminator;
  zprava(mz,2,20);
end;
 
procedure firstmenu;forward;
 
procedure hra;
var
    mhmenu,mmenu,mrozdel:menuitems;
begin
  volnychlidi:=prov.lidi;
  volnychotroku:=prov.otroci;
  mmenu[0]:='Nova hra';
  mmenu[1]:='Nahrat hru';
  mmenu[2]:='Ulozit hru';
  mmenu[3]:=volno;
  mmenu[4]:='Hlavni menu';
  mmenu[5]:=terminator;
  mrozdel[0]:='Poddani';
  mrozdel[1]:='Otroci';
  mrozdel[2]:=volno;
  mrozdel[3]:='Hlavni menu';
  mrozdel[4]:=terminator;
  mhmenu[0]:='Soubor';
  mhmenu[1]:='Stav provincie';
  mhmenu[2]:='Trh';
  mhmenu[3]:='Rozdeleni prace';
  mhmenu[4]:='Dalsi rok';
  mhmenu[5]:='Help';
  mhmenu[6]:=linka;
  mhmenu[7]:='Konec hry';
  mhmenu[8]:=terminator;
  repeat
  opravlidi;
  opravotroky;
  center(o1,length(mhmenu[3]));
  if rok <= 20 then case menu(o1,mhmenu,19,1,10) of
  1: begin
       {soubor}
       center(o1,length(mmenu[4]));
       case menu(o1,mmenu,19,1,10) of
       1:new;
       2:loadhru;
       3:savehru;
       4:begin end;
       end;
     end;
     {stav provincie}
  2: statusprov;
     {trh}
  3: nakup;
  4: begin
       {rozdeleni}
       center(o1,length(mrozdel[3]));
       case menu(o1,mrozdel,19,1,10) of
       1:poddani;
       2:otroci;
       3:begin end;
       end;
     end;
  5: begin
       {konec tahu}
       znova:=true;
       endturn(prov);
       if (rok <= 20) and (prov.stupnu<=15) then statusprov;
     end;
  6: help;
  7: konec;
  end;
  until (rok>=20)or (prov.stupnu>=15);
  if prov.stupnu>=15 then zaver;
  firstmenu;
end;
 
procedure firstmenu;
var canexit:boolean;
    mfirst:menuitems;
begin
  canexit:=false;
  assignokno(o1,100,80,0,0,16,1,0);
  canexit:=false;
  repeat
  mfirst[0]:='Nova hra';
  mfirst[1]:='Nahrat hru';
  mfirst[2]:='Help';
  mfirst[3]:=linka;
  mfirst[4]:='Konec';
  mfirst[5]:=terminator;
  center(o1,length(mfirst[1]));
  case menu(o1,mfirst,19,1,10) of
  1: begin
       new;
       canexit:=true;
     end;
  2: canexit:=loadhru;
  3: help;
  4: konec;
  end;
  until canexit;
  hra;
end;
 
procedure uvod;
var mu:menuitems;
begin
  mu[0]:='Empty Head';
  mu[1]:=volno;
  mu[2]:='   uvadi';
  mu[3]:=terminator;
  zprava(mu,2,5);
  mu[0]:='  textovou';
  mu[1]:='    hru';
  mu[2]:='v grafickem';
  mu[3]:=' prostredi';
  mu[4]:=terminator;
  zprava(mu,2,5);
  mu[0]:='PYRAMIDA';
  mu[1]:=terminator;
  zprava(mu,2,5);
  mu[0]:='Namet:';
  mu[1]:=volno;
  mu[2]:=' Textova hra';
  mu[3]:=' na Atari XE/XL';
  mu[4]:=' od neznameho';
  mu[5]:=' vyrobce';
  mu[6]:=terminator;
  zprava(mu,2,5);
  mu[0]:='Zpracovani:';
  mu[1]:=volno;
  mu[2]:=' Empty Head Production';
  mu[3]:=terminator;
  zprava(mu,2,5);
  mu[0]:='Obrazek:';
  mu[1]:=volno;
  mu[2]:=' George Killer';
  mu[3]:=terminator;
  zprava(mu,2,5);
  mu[0]:='Nazvy provincii:';
  mu[1]:=volno;
  mu[2]:=' SvoPo SOFTWORKS U.P.K.';
  mu[3]:=terminator;
  zprava(mu,2,5);
  mu[0]:='Texty:';
  mu[1]:=volno;
  mu[2]:=' Big Mac Lukas';
  mu[3]:=terminator;
  zprava(mu,2,5);
end;
 
var
    N: NameStr;
    E: ExtStr;
    w:word;
 
begin
  FSplit(paramstr(0), exepath, N, E);
  error:=myerror;
  zobrzazraku:=zazrakobr;
  initgraph;
  read_pcx(exepath+'pyramida.pcx',pozadi);
  redrawall;
                         {read - only}
  assignokno(pyramida,120,4,200,20,16,1,4);
  oknoopen(pyramida);
  gwrite('Pyramida',16,2,16,1);
  w:=getwinver;
  uvod;
  if w<>0 then if w=1024 then zobrzazraku('Tato hra Vam pobezi lepe'+#13+'pod systemem MS-DOS a ne'+#13+'      WINDOWS 95 !!')
  else if w <> 1024 then zobrzazraku('Tato hra Vam pobezi lepe'+#13+'pod systemem MS-DOS a ne'+#13+'     WINDOWS '+
         inttostr(hi(w))+'.'+inttostr(lo(w))+' !!');
  if (w<>0) and getvolkov then zobrzazraku('Kdyz chci, aby Volkov bezel po-'+#13+'radne, spustim ho pod MS-DOSem !');
  firstmenu;
end.