{ 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.