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

{ oknaunit.pas                          Copyright (c) Petr Masopust  }
{ Unit pre hru pyramida.pas                                          }
{ Pre zobrazovanie okien a otazok v hre.                             }
{                                                                    }
{ Datum:03.09.2018                              http://www.trsek.com }
unit oknaunit;
interface
uses dos,crt,univgraf;
const linka=#1;
      volno=#2;
      terminator=#0;
      Null    =   #0; { znak NULL }
      BS      =   #8; { kl vesa BACKSPACE }
      CR      =  #13; { kl vesa ENTER }
   PgUp    = #201; { kl vesa str nka nahoru }
   PgDown    = #209; { kl vesa str nka dolu }
      Esc     =  #27; { kl vesa ESC }
      Left    = #203; { kl vesa ¨ipka vlevo }
      Right   = #205; { kl vesa ¨ipka vpravo }
      Up      = #200; { kl vesa ¨ipka nahoru }
      Down    = #208; { kl vesa ¨ipka dolu }
      ano=true;
      ne=false;
 
type okno=record
            x1,y1,x2,y2:integer;
            barva,barvaramecku:byte;
            krok:byte;
          end;
     menuitems=array[0..10] of string[33];
     charset=set of char;
     polepozadi=array[0..199,0..319]of byte;
 
procedure oknoopen(o:okno);
procedure oknoclose(o:okno);
procedure redrawall;
procedure naplnpozadi;
procedure center(var o:okno;kolikznaku:byte);
procedure assignokno(var o:okno;x1,y1,x2,y2:integer;barva,barvaramecku,krok:byte);
procedure deletemenuitems(var m:menuitems);
procedure dotazok(s:string;cz:byte);
procedure dotazviceok(m:menuitems;cz:byte);
function menu(o:okno;polozky:menuitems;cz,default,barvadefault:byte):byte;
function inputline(o:okno;cz,max:byte;popis:string):string;
function dotaz(o:okno;popis:string;cz,barvadefault:byte;default:boolean):boolean;
procedure zprava(m:menuitems;cz,w:byte);
function onetime:real;
 
var pozadi:^polepozadi;
    krokmenu:byte;
implementation
var oldexit:pointer;
 
procedure fillbar(x,y,x1,y1:integer;c,cc:byte);
var px,py:integer;
begin
  for px:=x to x1 do for py:=y to y1 do putpixel(px,py,c);
  ctverec(x,y,x1,y1,cc);
end;
 
procedure oknoopen(o:okno);
var
    deltax,deltay,px,py:integer;
    i:byte;
begin
  px:=o.x1+abs(o.x2-o.x1) div 2;
  py:=o.y1+abs(o.y2-o.y1) div 2;
  if o.krok=0 then o.krok:=1;
  deltax:=abs(o.x2-o.x1) div (2*o.krok);
  deltay:=abs(o.y2-o.y1) div (2*o.krok);
  for i:=1 to o.krok do begin
    fillbar(px-deltax*i,py-deltay*i,px+deltax*i,py+deltay*i,o.barva,o.barvaramecku);
    delay(50);
  end;
end;
 
procedure oknoclose(o:okno);
var
    rx,ry,deltax,deltay,px,py:integer;
    i:byte;
begin
  px:=o.x1+abs(o.x2-o.x1) div 2;
  py:=o.y1+abs(o.y2-o.y1) div 2;
  if o.krok=0 then o.krok:=1;
  deltax:=abs(o.x2-o.x1) div (2*o.krok);
  deltay:=abs(o.y2-o.y1) div (2*o.krok);
  for i:=o.krok downto 1 do begin
    ctverec(px-deltax*(i-1)+1,py-deltay*(i-1)+1,px+deltax*(i-1)-1,py+deltay*(i-1)-1,o.barvaramecku);
    for rx:=px-deltax*i to px+deltax*i do for ry:=py-deltay*i to py-deltay*(i-1) do putpixel(rx,ry,pozadi^[ry,rx]);
    for rx:=px-deltax*i to px+deltax*i do for ry:=py+deltay*i downto py+deltay*(i-1) do putpixel(rx,ry,pozadi^[ry,rx]);
    for rx:=px-deltax*i to px-deltax*(i-1) do for ry:=py-deltay*i to py+deltay*i do putpixel(rx,ry,pozadi^[ry,rx]);
    for rx:=px+deltax*i downto px+deltax*(i-1) do for ry:=py-deltay*i to py+deltay*i do putpixel(rx,ry,pozadi^[ry,rx]);
    delay(50);
  end;
  putpixel(px,py,pozadi^[py,px]);
end;
 
procedure redrawall;
begin
  move(pozadi^,mem[sega000:0000],sizeof(pozadi^));
end;
 
procedure naplnpozadi;
begin
  move(mem[sega000:0000],pozadi^,sizeof(pozadi^));
end;
 
procedure center(var o:okno;kolikznaku:byte);
begin
  o.x1:=(getmaxx-kolikznaku*8-8) div 2;
  o.x2:=getmaxx - o.x1;
  o.y1:=(getmaxy - 16) div 2;
  o.y2:=getmaxy - o.y1;
end;
 
procedure deletemenuitems(var m:menuitems);
var i:byte;
begin
  for i:=1 to 10 do m[i]:='';
  m[0]:=terminator;
end;
 
procedure assignokno(var o:okno;x1,y1,x2,y2:integer;barva,barvaramecku,krok:byte);
begin
  o.x1:=x1;
  o.y1:=y1;
  o.x2:=x2;
  o.y2:=y2;
  o.barva:=barva;
  o.barvaramecku:=barvaramecku;
  o.krok:=krok;
end;
 
function IntToStr(I: integer): String;
var
  S: string[11];
begin
  Str(I, S);
  IntToStr := S;
end;
 
procedure clearta;assembler;
asm
  mov ah,0ch
  mov al,6
  mov dl,0ffh
  int 21h
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;
 
    function GetString(X,Y,Delka,cp,cz : byte) : string;
    { Delka : delka pole, do ktereho se ma retezec vkladat }
 
    function Input(Delka : byte;
                   var R : string) : char;
    { Funkce  ceka  na  vstup  z  klavesnice  a  vraci  znakovou
      reprezentaci stisknute klavesy. }
    var
       Znak: char;           { vkladany znak }
       D   : byte absolute R;{ aktualni delka vkladaneho retezce}
    begin
       Znak:= GetLegalKey([#32..#126, BS, CR, ESC]);
       case Znak of
       { jestlize se stiskne zobrazitelny znak ze  spodni  poloviny
         tabulky ASCII a aktualni delka retezce je mensi nez povolene
         maximum, znak se prida do retezce  a  zobrazi  za  poslednim
         znakem retezce }
         #32..#126 : if D < Delka then
                     begin
                        R := R + Znak;
                        gWrite(r,cz,cp,x,y);
                    end;
         { jestlize se stiskne klavesa  BackSpace,  posledni  vlozeny
           znak se vymaze }
         BS       : begin
                       if wherex > x then begin
                         Delete(R,D,1);
                         fillbar(x*8,y*8,wherex*8,y*8+8,cz,cz);
                         gWrite(r,cz,cp,x,y);
                       end;
                    end;
        ESC       : R := ESC;
      end;
      Input := Znak;
    end;
 
    var
       R  : string;
       Z  : char;
 
    begin
       R := '';
       GotoXY(X, Y);
       repeat
           Z := Input(Delka, R);
       until Z in [ESC, CR];
       if R <> ESC then
           GetString := R
       else
           GetString := '';
    end;
 
procedure prepismenu(polozky:menuitems;max,pocet,barvapozadi,cz,barvadefault,px,py:byte;default:byte);
var pom,i,j:byte;
 
begin
  for i:=0 to pocet-1 do begin
    case polozky[i][4] of
    #1: for j:=0 to max-2 do gwrite('-',barvapozadi,cz,px+j,py+i);
    #2: begin end;
    else begin
           if polozky[i][2] <> '.' then pom:=10
           else pom:=ord(polozky[i][1])-48;
           if default = pom then gwrite(polozky[i],barvapozadi,barvadefault,px,py+i)
           else gwrite(polozky[i],barvapozadi,cz,px,py+i);
         end;
    end;
  end;
end;
 
function menu(o:okno;polozky:menuitems;cz,default,barvadefault:byte):byte;
var i,px,py,max,pocet:integer;
    j,cisla:byte;
    canexit,konecpolozek:boolean;
    pom,c,plus:char;
 
    s:string[3];
begin
  max:=0;
  pocet:=0;
  cisla:=1;
  i:=0;
  o.x1:=o.x1 - o.x1 mod 4;
  o.y1:=o.y1 - (o.y1 + 2) mod 4;
  repeat
    if polozky[i]=#0 then konecpolozek:=true
    else konecpolozek:=false;
    polozky[i]:=inttostr(cisla)+'. '+polozky[i];
    if (polozky[i][4] <> #1) then if (polozky[i][4] <> #2) then if (polozky[i][4] <> #0) then inc(cisla);
    if length(polozky[i]) > max then max:=length(polozky[i]);
    inc(pocet);
    inc(i);
  until (i>=11) or konecpolozek;
  inc(max);
  if odd(max) then inc(max);
  dec(cisla);
  inc(o.x1,o.x1 mod 8);
  inc(o.y1,o.y1 mod 8);
  px:=o.x1 div 8;
  py:=o.y1 div 8;
  o.x2:=o.x1+max*8;
  o.y2:=o.y1+i*8;
  dec(o.x1,4);
  dec(o.x2,4);
  dec(o.y1,12);
  dec(o.y2,4);
  o.krok:=krokmenu;
  dec(i);
  dec(pocet);
  oknoopen(o);
  i:=0;
    {  (s: string;cp,cz,x,y: byte);
                            okno=record
            x1,y1,x2,y2:integer;
            barva,barvaramecku:byte;
            krok:byte;
          end;
 
                           fillbar(x*8,y*8,wherex*8,y*8+8,16,16);
                         gWrite(r,16,10,x,y);}
  if cisla = 10 then dec(cisla);
  if cisla = 11 then begin
    plus:='0';
    c:='9';
  end else begin
    plus:=#0;
    s:=inttostr(cisla);
    c:=s[1];
  end;
  canexit:=false;
  repeat
    prepismenu(polozky,max,pocet,o.barva,cz,barvadefault,px,py,default);
    pom:=getlegalkey(['1'..c,plus,cr,up,pgup,pgdown,down]);
    case pom of
    pgup:default:=1;
    pgdown:default:=cisla;
    up: if default = 1 then default:=cisla
        else dec(default);
    down: if default = cisla then default:=1
          else inc(default);
    cr: begin
          pom:=chr(default+48);
          canexit:=true;
        end;
    else canexit:=true;
    end;
  until canexit;
  oknoclose(o);
  menu:=(ord(pom)-48);
end;
 
function inputline(o:okno;cz,max:byte;popis:string):string;
var prod,px,py:byte;
begin
  if length(popis) > max then prod:=length(popis)
  else prod:=max;
  if odd(prod) then inc(prod);
  center(o,prod);
  o.x1:=o.x1 - o.x1 mod 4;
  o.y1:=o.y1 - (o.y1 + 2) mod 4;
  inc(o.x1,o.x1 mod 8);
  inc(o.y1,o.y1 mod 8);
  px:=o.x1 div 8;
  py:=o.y1 div 8;
  o.x2:=o.x1+prod*8+16;
  o.y2:=o.y1+24;
  dec(o.x1,4);
  dec(o.x2,4);
  dec(o.y1,12);
  dec(o.y2,4);
  o.krok:=krokmenu;
  oknoopen(o);
  gwrite(popis,o.barva,cz,px,py);
{  (s: string;cp,cz,x,y: byte);}
  inputline:=getstring(px,py+1,max,cz,o.barva);
  oknoclose(o);
end;
 
procedure prepis(barvapozadi,cz,barvadefault,pa,pn,py:byte;default:boolean);
var barva:byte;
begin
  if default then barva:=barvadefault
  else barva:=cz;
  gwrite('Ano',barvapozadi,barva,pa,py);
  if not default then barva:=barvadefault
  else barva:=cz;
  gwrite('Ne',barvapozadi,barva,pn,py);
end;
 
function dotaz(o:okno;popis:string;cz,barvadefault:byte;default:boolean):boolean;
var prod,px,py,pa,pn:byte;
    c:char;
    canexit:boolean;
 
begin
  if length(popis) < 10 then prod:=10
  else prod:=length(popis);
  if odd(prod) then inc(prod);
  center(o,prod);
  o.x1:=o.x1 - o.x1 mod 4;
  o.y1:=o.y1 - (o.y1 + 2) mod 4;
  inc(o.x1,o.x1 mod 8);
  inc(o.y1,o.y1 mod 8);
  px:=o.x1 div 8;
  py:=o.y1 div 8;
  o.x2:=o.x1+prod*8+16;
  o.y2:=o.y1+24;
  dec(o.x1,4);
  dec(o.x2,4);
  dec(o.y1,12);
  dec(o.y2,4);
  o.krok:=krokmenu;
  oknoopen(o);
  gwrite(popis,o.barva,cz,px,py);
{  (s: string;cp,cz,x,y: byte);}
  inc(py);
  pa:=px + prod div 2 - 4;
  pn:=px + prod div 2 + 2;
  canexit:=false;
  repeat
  prepis(o.barva,cz,barvadefault,pa,pn,py,default);
  c:=GetLegalKey([left,right,cr]);
  case c of
    left,right: default:=not default;
    cr: canexit:=true;
  end;
  until canexit;
  oknoclose(o);
  dotaz:=default;
end;
 
procedure dotazok(s:string;cz:byte);
var o:okno;
begin
  assignokno(o,0,0,0,0,16,2,4);
  center(o,length(s)+1);
  inc(o.y2,8);
  oknoopen(o);
  gwrite(s,16,cz,20-length(s)div 2,12);
  gwrite('OK',16,3,19,13);
  getlegalkey([cr]);
  oknoclose(o);
end;
 
procedure dotazviceok(m:menuitems;cz:byte);
var o:okno;
    max,pocet,i,j:byte;
begin
  max:=0;
  pocet:=0;
  repeat
    if length(m[pocet]) > max then max:=length(m[pocet]);
    inc(pocet);
  until (pocet>=11)or(m[pocet][1]=#0);
  dec(pocet);
  assignokno(o,0,0,0,0,16,2,4);
  if odd(max) then inc(max);
  center(o,max);
  o.y1:=(11-pocet div 2)*8;
  o.y2:=(14+pocet div 2)*8;
  dec(o.y1,4);
  inc(o.y2,4);
  o.krok:=krokmenu;
  oknoopen(o);
  for i:=0 to pocet do case m[i][1] of
  volno: begin end;
  linka: for j:=0 to max-1 do gwrite('-',16,cz,20 - max div 2+j,11 - pocet div 2 + i);
  else  gwrite(m[i],16,cz,20 - max div 2,11 - pocet div 2 + i);
  end;
  gwrite('OK',16,3,19,13 + pocet div 2);
  getlegalkey([cr]);
  oknoclose(o);
end;
 
function onetime:real;
var h,m,s,hund:word;
    pom:real;
begin
  gettime(h,m,s,hund);
  pom:=h*3600+m*60;
  pom:=pom+s+hund*0.01;
  onetime:=pom;
end;
 
 
procedure wait(s:word);
var t:real;
begin
  t:=onetime;
  clearta;
  repeat until keypressed or (onetime-t >= s);
end;
 
 
procedure zprava(m:menuitems;cz,w:byte);
var o:okno;
    max,pocet,i,j:byte;
begin
  max:=0;
  pocet:=0;
  repeat
    if length(m[pocet]) > max then max:=length(m[pocet]);
    inc(pocet);
  until (pocet>=11)or(m[pocet][1]=#0);
  dec(pocet);
  assignokno(o,0,0,0,0,16,2,4);
  if odd(max) then inc(max);
  center(o,max);
  o.y1:=(11-pocet div 2)*8;
  if pocet <3 then o.y2:=(12+pocet div 2)*8
  else o.y2:=(13+pocet div 2)*8;
  dec(o.y1,4);
  inc(o.y2,4);
  o.krok:=krokmenu;
  oknoopen(o);
  for i:=0 to pocet do case m[i][1] of
  volno: begin end;
  linka: for j:=0 to max-1 do gwrite('-',16,cz,20 - max div 2+j,11 - pocet div 2 + i);
  else  gwrite(m[i],16,cz,20 - max div 2,11 - pocet div 2 + i);
  end;
  wait(w);
  oknoclose(o);
end;
 
{$F+}
procedure endproc;
begin
  exitproc:=oldexit;
  dispose(pozadi);
end;
{$F-}
 
begin
  if maxavail < sizeof(polepozadi) then begin
    writeln('Malo pameti !');
    halt(1);
  end else begin
    new(pozadi);
    oldexit:=exitproc;
    exitproc:=@endproc;
    krokmenu:=4;
  end;
end.