Dze je subor www.TrSek.com/pas/trsek.pas{ TRSEK.PAS Copyright (c) TrSek alias Zdeno Sekerak }
{ Kniznica pouzivana skoro vsetkymi programami. }
{ Program POUZI.PAS demonstruje vsetky jej funkcie a procedury. }
{ }
{ Datum:24.10.1995 http://www.trsek.com }
type byte_poin = record { Kvoli oknam }
byt:array[1..2000] of byte;
end;
var ctrsek_b,ctrsek_f:byte;
tdel:integer; { Pauza pri vytvarani okna}
MinWin,MaxWin:integer;
pom,win_pointer,wfirst_pointer:^win_poin; { Smerniky na okna }
win_pocet:byte; { Udrzuje pocet okien }
procedure KurzorZap(ZapVyp:boolean);
procedure farba(x,y:integer);
procedure set_insert(ins:boolean);
function ctrl_akt:boolean;
function alt_akt:boolean;
function nothing(i:integer):string;
function zarovnaj(text:string;i:integer):string;
procedure save_win;
procedure old_win;
procedure writexy(x,y:integer;s:string);
function tread(x,y:integer; d:byte; text:string; sedy,pret:char):string;
procedure open_win(xl,yl,xp,yp:integer;text:string;ramt:byte);
function otazka(x,y:integer;s1,s2,s3:string;color:byte;typ:byte):integer;
procedure koniec(naz_prog,rok:string);
procedure clear_keyb;
function get_znak(x,y:byte;var farba:byte):byte;
procedure put_znak(x,y,farba,znak:byte);
procedure zarad_okno (var win_pointer:win_poin;x1,y1,x2,y2:byte);
function get_window(x1,y1,x2,y2:integer):integer;
function put_window(por:integer;xn1,yn1,xn2,yn2:integer):integer;
function vyrad_okno (por:integer):integer;
procedure rem_all_win;
function treadkey:char;
procedure priklad;
procedure help(str:char);
implementation
uses crt,dos;
procedure KurzorZap(ZapVyp:boolean);
var Regs : Registers;
begin
with Regs do
begin
AH := $03;
BH := $00;
Intr($10,Regs);
If not (Zapvyp) then
CH := CH or $20
else
CH := CH and $DF;
AH := $01;
Intr($10,Regs);
end;
end;
procedure farba(x,y:integer);
begin
if x<>-1 then begin textbackground(x);ctrsek_b:=x;end;
if y<>-1 then begin textcolor(y);ctrsek_f:=y;end;
end;
procedure set_insert(ins:boolean);
var Reg:registers;
begin
Reg.AH:=$01;
Reg.CL:=$1E;
if ins then Reg.CH:=$1D
else Reg.CH:=$01;
Intr($10,Reg);
end;
function ctrl_akt:boolean;
begin
if (mem[0:$417] and 4) > 0 then ctrl_akt:=true
else ctrl_akt:=false;
end;
function alt_akt:boolean;
begin
if (mem[0:$417] and 8) > 0 then alt_akt:=true
else alt_akt:=false;
end;
function nothing(i:integer):string;
const prazdny=' ';
begin
nothing:=copy(prazdny,1,i);
end;
function zarovnaj(text:string;i:integer):string;
begin
zarovnaj:=copy(text+nothing(i-length(text)),1,i);
end;
procedure save_win;
begin
MinWin:=WindMin;MaxWin:=WindMax;
end;
procedure old_win;
begin
window(Lo(MinWin)+1,Hi(MinWin)+1,Lo(MaxWin)+1,Hi(MaxWin)+1);
end;
procedure writexy(x,y:integer;s:string);
begin
gotoxy(x,y);
write(s);
end;
function tread(x,y:integer; d:byte; text:string; sedy,pret:char):string;
var xp :integer; { Pozicia kurzora }
kl :char;
ins:boolean;
von:boolean;
pis:boolean;
fir:boolean;
old_text:string;
begin
farba(ctrsek_b,ctrsek_f);kurzorZap(true);
ins:=true;set_insert(ins);
kurzorZap(false);
text:=zarovnaj(text,d); { Priprava !!! }
if (x<1) then x:=1;
if (y<1) then y:=1;
if (x+d > Lo(WindMax)+1 ) then x:=Hi(WindMax)+1-d;
if (y > Hi(WindMax)+1 ) then y:=Hi(WindMax)+1;
xp:=1;x:=x-1;von:=false;pis:=true;fir:=true;
if sedy<>#0 then sedy:=pret;old_text:=text;
repeat
if pis then begin
KurzorZap(false);
WriteXY(x+1,y,text);
pis:=false;
end;
KurzorZap(true);
gotoxy(x+xp,y);
if fir then kl:=sedy
else kl:=ReadKey;
if ( kl=#0 ) then begin
if fir then kl:=pret
else kl:=ReadKey;
case kl of
#77:begin { sipka vpravo }
xp:=xp+1;
if (xp>d) then xp:=d;
end;
#75:begin { sipka vlavo }
xp:=xp-1;
if (xp<1) then xp:=1;
end;
#83:begin { DEL }
delete(text,xp,1);
text:=text+' ';
pis:=true;
end;
#80:von:=true; { sipka dole }
#72:von:=true; { sipka hore }
#59:begin { F1-vrat text }
text:=old_text;
pis:=true;
end;
#82:begin { Insert }
ins:=not(ins);
set_insert(ins);
end;
#71:xp:=1; { HOME }
#79:begin { End }
xp:=d;
while ((xp>1) and (text[xp-1]=' ')) do
dec(xp);
end;
end; { od CASE }
end { od IF kl=#0 }
else begin
case kl of
#27:von:=true;
#13:von:=true;
#08:if (xp>1) then begin
delete(text,xp-1,1);text:=zarovnaj(text,d);
pis:=true;dec(xp);
end;
else begin { ELSE ku CASE }
if ins then begin
insert(kl,text,xp);
text:=zarovnaj(text,d);
end
else text[xp]:=kl;
pis:=true;inc(xp);
if (xp>d) then von:=true;
end; { end od begin pri ELSE ku CASE }
end; { od druheho CASE }
end; { od ELSE }
if fir then begin
von:=false;
fir:=false;
end;
until (von);
if (kl=#27) then tread:=old_text
else tread:=text;
end;
procedure open_win(xl,yl,xp,yp:integer;text:string;ramt:byte);
const typr:array[1..4,1..6] of char=
(('Í','»','º','¼','È','É'),
('Ä','·','º','½','Ó','Ö'),
('Í','¸','³','¾','Ô','Õ'),
('Ä','¿','³','Ù','À','Ú'));
var i,xs,ys:integer;
p:real;
begin
xs:=(xp-xl) div 2;
ys:=(yp-yl) div 2;
KurzorZap(false);
if (xs>ys) then begin
for i:=1 to xs-ys do begin
Window(xl+xs-i,yl+ys,xl+xs+i,yl+ys);
delay(tdel);
clrscr;
end;
for i:=xs-ys to xs do begin
Window(xl+xs-i,yl+xs-i,xl+xs+i,yl+2*ys-xs+i);
delay(tdel);
clrscr;
end;
end
else begin
for i:=1 to ys-xs do begin
Window(xl+xs,yl+ys-i,xl+xs,yl+ys+i);
delay(tdel);
clrscr;
end;
for i:=ys-xs to ys do begin
Window(xl+ys-i,yl+ys-i,xl+2*xs-ys+i,yl+ys+i);
delay(tdel);
clrscr;
end;
end;
Window(xl,yl,xp,yp);
clrscr;
Window(1,1,80,25);
for i:=xl to xp do WriteXY(i,yl,typr[ramt,1]);
WriteXY(xp,yl,typr[ramt,2]);
for i:=yl+1 to yp do WriteXY(xp,i,typr[ramt,3]);
WriteXY(xp,yp,typr[ramt,4]);
for i:=xp-1 downto xl do WriteXY(i,yp,typr[ramt,1]);
WriteXY(xl,yp,typr[ramt,5]);
for i:=yp-1 downto yl do WriteXY(xl,i,typr[ramt,3]);
WriteXY(xl,yl,typr[ramt,6]);
if text<>'' then WriteXY(xl+xs-(length(text) div 2),yl,' '+text+' ');
Window(xl+1,yl+1,xp-1,yp-1);
end;
function otazka(x,y:integer;s1,s2,s3:string;color:byte;typ:byte):integer;
const otyp:array[0..3,1..2] of byte =
((26,27),(16,17),(62,60),(175,174));
var ch:char;
s:array[1..3] of string;
pk:array[1..2,0..2] of byte; { Pozicia kurzora }
i,odel:integer;
otat,otap:byte;
begin
{ Urci typ uvodzoviek }
otat:=(typ and 1)+(typ and 2);otap:=((typ and 4)+(typ and 8)) div 4;
if (otap and 2)=2 then odel:=1
else odel:=5;
{ Z akych moznosti si ma vyberat a ich suradnice }
s[1]:=s1;pk[2,0]:=0;pk[1,0]:=x;
s[2]:=s2;pk[2,1]:=0;pk[1,1]:=x+length(s1)+odel;
s[3]:=s3;pk[2,2]:=0;pk[1,2]:=x+length(s1)+length(s2)+2*odel;
{ Pre CRTL sekvenciu }
for i:=length(s1) downto 1 do if UpCase(s1[i])=s1[i] then pk[2,0]:=ord(s1[i]);
for i:=length(s2) downto 1 do if UpCase(s2[i])=s2[i] then pk[2,1]:=ord(s2[i]);
for i:=length(s3) downto 1 do if UpCase(s3[i])=s3[i] then pk[2,2]:=ord(s3[i]);
{ Ma to byt spolu,a lebo ma mat rovnake medzery }
if (otap and 1)=1 then begin
i:=length(s1);
if length(s2)>i then i:=length(s2);
if length(s3)>i then i:=length(s3);
pk[1,1]:=x+i+odel;
pk[1,2]:=x+2*(i+odel);
end;
textbackground(ctrsek_b);
WriteXY(pk[1,0],y,chr(otyp[otat,1])+s1+chr(otyp[otat,2]));
if s2<>'' then WriteXY(pk[1,1],y,' '+s2+' ');
if s3<>'' then WriteXY(pk[1,2],y,' '+s3+' ');
i:=0;
repeat
textbackground(color);
WriteXY(pk[1,i],y,chr(otyp[otat,1])+s[i+1]+chr(otyp[otat,2]));
ch:=readkey;
if ctrl_akt then begin { Stlacil CRTL }
textbackground(ctrsek_b);
WriteXY(pk[1,i],y,' '+s[i+1]+' ');
textbackground(color);
if Ord(ch)+64 = pk[2,0] then begin i:=0;ch:=#13;end;
if Ord(ch)+64 = pk[2,1] then begin i:=1;ch:=#13;end;
if Ord(ch)+64 = pk[2,2] then begin i:=2;ch:=#13;end;
if ch=#13 then
WriteXY(pk[1,i],y,chr(otyp[otat,1])+s[i+1]+chr(otyp[otat,2]));
end;
if ch=#0 then begin
ch:=readkey;
if ch=#77 then begin { Pohyb sipkami }
textbackground(ctrsek_b);WriteXY(pk[1,i],y,' '+s[i+1]+' ');
i:=i+1;
if s[i+1]='' then i:=i-1;
if i>2 then i:=2;
end;
if ch=#75 then begin
textbackground(ctrsek_b);WriteXY(pk[1,i],y,' '+s[i+1]+' ');
i:=i-1;
if i<0 then i:=0;
end;
end;
if ch=#27 then begin otazka:=0;exit;end;
until (ch in [#13]); { Koniec }
otazka:=i+1;
end;
procedure koniec(naz_prog,rok:string);
begin
farba(BLACK,-1);
clrscr;
farba(BLUE,YELLOW);
writeln;
writeln(zarovnaj(naz_prog,15)+
' Software by TRSEK. All right reserved, copyright TRSEK (c) '+rok+'.');
end;
procedure clear_keyb;
var Reg:Registers;
begin
Reg.AX:=$C06;
Reg.DL:=$FF;
intr($21,Reg);
end;
function get_znak(x,y:byte;var farba:byte):byte;
var reg:registers;
xo,yo:integer;
begin
xo:=wherex;yo:=wherey;
save_win;
window(1,1,80,25);
win_pointer.zani:=NIL;
if wfirst_pointer=NIL then begin
wfirst_pointer:=@win_pointer;
end
else begin
pom:=wfirst_pointer;
while (pom^.zani<>NIL) do pom:=pom^.zani;
pom^.zani:=pointer(@win_pointer);
end;
end;
function get_window(x1,y1,x2,y2:integer):integer;
var x,y,i:integer;
reg:registers;
pom1,pom2:^byte_poin;
velkost:word;
begin
save_win;
get_window:=0;
{ Ziskaj pamet + 2b pred, 2b zani, 1b poradie okna }
{ 1b celkova sirka, 1b celkova vyska }
velkost:= SizeOf( Win_poin ) + 2*(x2-x1+1)*(y2-y1+1);
if velkost>MaxAvail then begin
write('Malo pamete, k dispozicii iba ',MaxAvail,' B konvencnej pamete.');
exit;
end;
GetMem(win_pointer,SizeOf( Win_poin) ); { Rezervuj pamet pre smernik }
GetMem(win_pointer^.znaky,(x2-x1+1)*(y2-y1+1) ); { Rezervuj pamet pre znaky }
GetMem(win_pointer^.farby,(x2-x1+1)*(y2-y1+1) ); { Rezervuj pamet pre farby }
window(1,1,80,25);
i:=0;
for x:=x1 to x2 do
for y:=y1 to y2 do begin
gotoxy(x,y);
reg.ah:=8;
reg.bh:=0;
intr($10,reg);
inc(i);
pom1^.byt[i]:=reg.ah;
pom2^.byt[i]:=reg.al;
end;
old_win;
get_window:=win_pocet;
end;
function put_window(por:integer;xn1,yn1,xn2,yn2:integer):integer;
var x,y,i:integer;
x1,x2,y1,y2:integer;
reg:registers;
pom1,pom2:^byte_poin;
begin
win_pointer:=wfirst_pointer;
while ( (win_pointer^.zani<>NIL) and (win_pointer^.poradie<>por) ) do
win_pointer:=win_pointer^.zani;
if win_pointer^.poradie<>por then begin
put_window:=1;
exit;
end;
with win_pointer^ do begin
x1:=xova;
y1:=yova;
x2:=x1+x_vel;
y2:=y1+y_vel;
pom1:=znaky;
pom2:=farby;
end;
if xn1=0 then xn1:=x1;
if yn1=0 then yn1:=y1;
if xn2=0 then xn2:=80;
if yn2=0 then yn2:=25;
xn1:=xn1-x1;
yn1:=yn1-y1;
window(1,1,80,25);
i:=0;
for x:=x1 to x2 do
for y:=y1 to y2 do begin
gotoxy(x+xn1,y+yn1);
reg.ah:=$9;
reg.bh:=0;
inc(i);
reg.al:=pom2^.byt[i];
reg.bl:=pom1^.byt[i];
reg.cx:=1;
if (y-y1<=yn2) and (x-x1<=xn2) then intr($10,reg);
end;
with win_pointer^ do window(old_x1,old_y1,old_x2,old_y2);
put_window:=0;
end;
function vyrad_okno (por:integer):integer;
var velkost:word;
begin
win_pointer:=wfirst_pointer;
pom:=NIL;
while ( (win_pointer^.zani<>NIL) and (win_pointer^.poradie<>por) ) do begin
pom:=win_pointer;
win_pointer:=win_pointer^.zani;
end;
if win_pointer^.poradie<>por then begin
vyrad_okno:=0;
exit;
end;
with win_pointer^ do begin
if (pom<>NIL) then pom^.zani:=win_pointer^.zani
else wfirst_pointer:=win_pointer^.zani;
if (pom=NIL) and (win_pointer^.zani=NIL) then begin
wfirst_pointer:=NIL;
win_pocet:=0;
end;
velkost:=(x_vel+1)*(y_vel+1);
end;
FreeMem(win_pointer^.farby, velkost ); { Uvolni pamet pre znaky }
FreeMem(win_pointer^.znaky, velkost ); { Uvolni pamet pre znaky }
FreeMem(win_pointer,SizeOf( win_poin ) ); { Uvolni pamet pre smernik }
vyrad_okno:=por;
end;
procedure rem_all_win;
var i,err:integer;
begin
for i:=win_pocet downto 1 do
err:=vyrad_okno(i);
end;
function treadkey:char;
var ch,c:char;
begin
repeat
ch:=readkey;
if ch=#0 then c:=readkey;
until (ch in [#27,#13,#32,'A'..'z']);
treadkey:=ch;
end;
procedure priklad;
begin
writeln;
writeln('Priklad:');
writeln('--------');
end;
procedure help(str:char);
var ch:char;
i:integer;
begin
window(1,1,80,25);
farba(BLACK,WHITE);
clrscr;
writeln('Vysvetlenie funkcii v tomto UNITE');
writeln('---------------------------------');
writeln;
writeln('Autorom unitu je Zdeno Sekerak alias TRSEK');
writeln('Adresa: Zdeno Sekerak');
writeln(' Trnkov 18');
writeln(' p.Kapusany');
writeln(' 082 12 okr.Presov');
writeln;
writeln('Autor si vyhradzuje prava na predaj, alebo inu obchodnu cinnost');
writeln('s tymto unitom. Je chapany ako FREEWARE.');
writeln;
writeln('V Presove 24.10.1995');
writeln;
writeln('Nabuduce: unit OBRAZ pre zobrazovanie a pracu s obrazkami TIF,BMP,PCX.');
writeln(' unit ASCII pre narodnu znakovu podporu a definovanie klavesnice.');
writeln;
writeln('Stlac klaves pre akukolvek pracu.');
ch:=treadkey;
repeat
writeln(' Zoznam prikazov:');
writeln('------------------');
writeln(' A- procedure KurzorZap (ZapVyp:boolean); ');
writeln(' B- procedure Farba (x,y:integer); ');
writeln(' C- procedure Insert_Kurzor (ins:boolean); ');
writeln(' D- function Ctrl_Akt:boolean; ');
writeln(' E- function Alt_Akt:boolean; ');
writeln(' F- function Nothing (i:integer): string; ');
writeln(' G- function Zarovnaj (text:string;i:integer): string; ');
writeln(' H- procedure Save_Win; ');
writeln(' I- procedure Old_Win; ');
writeln(' J- procedure WriteXY (x,y:integer;s:string); ');
writeln(' K- function Tread (x,y:integer; d:byte; text:string; sedy,pret:char): string;');
writeln(' L- procedure Open_Win (xl,yl,xp,yp:integer;text:string;ramt:byte); ');
writeln(' M- function Otazka (x,y:integer;s1,s2,s3:string;col:byte;typ:byte): integer;');
writeln(' N- procedure Koniec (naz_prog,rok:string); ');
writeln(' O- procedure Clear_Keyb; ');
writeln(' P- function Get_Znak (x,y:byte;farba:byte): byte; ');
writeln(' R- procedure Put_Znak (x,y,farba,znak:byte); ');
writeln(' S- procedure Zarad_Okno (win_pointer:win_poin;x1,y1,x2,y2:byte); ');
writeln(' T- function Get_Window (x1,y1,x2,y2:integer): integer; ');
writeln(' U- function Put_Window (por:integer;xn1,yn1,xn2,yn2:integer): integer; ');
writeln(' V- function Vyrad_Okno (por:integer): integer; ');
writeln(' X- procedure Rem_All_Win; ');
write('Stlac pismeno pre podrobny help (ESC-Koniec):');
if str<>' ' then begin ch:=str;str:=' ';end
else ch:=treadkey;
clrscr;
case Upcase(ch) of
'A':begin
writeln('procedure KurzorZap (ZapVyp:boolean); ');
writeln('-------------------------------------');
writeln('Zapina/vypina zobrazenie kurzora na obrazovke');
priklad;
writeln('KurzorZap(False);');
writeln('KurzorZap(True);');
end;
'B':begin
writeln('procedure Farba (x,y:integer); ');
writeln('------------------------------');
writeln('Nastavi farbu podkladu (prve cislo) a farbu pisma (druhe cislo).');
writeln('Pricom ak zadate farbu o hodnote -1 necha aktualnu.');
writeln('Simuluje prikazy TextBackGround + TextColor.');
writeln('Farby takto nastavene pouzivaju ostatne prikazy UNITu pracujuce s obrazovkou.');
writeln('Nastavuje vnutorne premenne CTRSEK_B farbou podkladu a');
writeln(' CTRSEK_F farbou pisma.');
priklad;
writeln('Farba(BLUE,YELLOW);');
end;
'C':begin
writeln('procedure Insert_Kurzor (ins:boolean); ');
writeln('--------------------------------------');
writeln('Zobrazi kurzor ako podciarnik, alebo plne okienko.');
writeln('Pouzitie pre naznacenie uzivatelovi, ze vkladane udaje budu INSERT.');
priklad;
writeln('Insert_Kurzor(True);');
end;
'D':begin
writeln('function Ctrl_Akt:boolean; ');
writeln('---------------------------');
writeln('Testuje aktivitu klavesi CTRL vo chvili ked bola funkcia zavolana.');
writeln('Pozor nie predosle, ale aktualne.');
priklad;
writeln('If Crtl_Akt then WriteLn('+chr(39)+'Klaves CRTL aktivny.'+chr(39)+');');
end;
'E':begin
writeln('function Alt_Akt:boolean; ');
writeln('--------------------------');
writeln('Testuje aktivitu klavesi ALT vo chvili ked bola funkcia zavolana.');
writeln('Pozor nie predosle, ale aktualne.');
priklad;
writeln('If Alt_Akt then WriteLn('+chr(39)+'Klaves ALT aktivny.'+chr(39)+');');
end;
'F':begin
writeln('function Nothing (i:integer): string; ');
writeln('--------------------------------------');
writeln('Funkcia vrati prazdny retazec o I medzerach.');
writeln('Obcas chcete aby to bol zdrojak prehladny.');
writeln('Niet nad taketo rutiny.');
priklad;
writeln('s:=Nothing(12);');
end;
'G':begin
writeln('function Zarovnaj (text:string;i:integer): string; ');
writeln('---------------------------------------------------');
writeln('Funkcia k retazcu prida tolko medzier, aby jeho dlzka bola i znakov.');
priklad;
writeln('Write( Zarovnaj('+chr(39)+'Text o 40 znakoch'+chr(39)+',40) );');
end;
'H':begin
writeln('procedure Save_Win; ');
writeln('-------------------');
writeln('Ulozi si suradnice aktivneho okna do vnutornych premennych MinWin a WinMax.');
writeln('Spatne ich pouzije pri obnoveny suradnic okna v procedure Old_Win.');
writeln('Pozor nepameta si jeho obsah nato je Get_Win.');
priklad;
writeln('Save_Win;');
writeln('Window(1,1,80,25);');
writeln('ClrScr;');
writeln('Old_Win');
end;
'I':begin
writeln('procedure Old_Win; ');
writeln('------------------');
writeln('Obnovi suradnice okna, ktore nastavil Save_win.');
writeln('Pozor nenakresli jeho obsah nato je Put_Win.');
priklad;
writeln('Save_Win;');
writeln('Window(1,1,80,25);');
writeln('ClrScr;');
writeln('Old_Win');
end;
'J':begin
writeln('procedure WriteXY (x,y:integer;s:string); ');
writeln('-----------------------------------------');
writeln('Vypise text S na X,Y poziciu na obrazovke.');
writeln('Kumulovane prikazy GotoXY a Write.');
priklad;
writeln('WriteXY (2,3,'+chr(39)+'Text na 2stlpci 3riadku'+chr(39)+');');
end;
'K':begin
writeln('function Tread (x,y:integer; d:byte; text:string; sedy,pret:char): string;');
writeln('---------------------------------------------------------------------------');
writeln('Read v okienku s editaciou a funkcnymi sipkami, INS, DEL, BACKSPACE, ECS.');
writeln('x,y - suradnice, kde citat');
writeln('d - dlzka textu aky sa ma nacitat (pohybovat)');
writeln('text- aky text ma poskytnut na editaciu');
writeln('sedy- ak je #0 znamena PRET je seda klavesa');
writeln(' pred vlastnou editaciu vykona pohyb klavesy.');
writeln(' Inac sedy znamena obycajny klaves.');
writeln;
writeln('Vrati naeditovany text.');
writeln('Uznava farby nastavene procedurou Farba.');
priklad;
writeln('Farba(Blue,Yellow);');
writeln('WriteXY(10,12,'+chr(39)+'Zadaj meno:'+chr(39)+');');
writeln('meno:=Tread(21,12,30,'+chr(39)+'BezMena'+chr(39)+',#0,#0);');
end;
'L':begin
writeln('procedure Open_Win (xl,yl,xp,yp:integer;text:string;ramt:byte); ');
writeln('---------------------------------------------------------------');
writeln('Efektne otvorenie okna s poziciu.');
writeln('xl,yl - lavy horny roh');
writeln('xp,yp - pravy dolny roh');
writeln('text - nadpis okna');
writeln('ramt - typ ramceka 1..4');
writeln('Uznava farby nastavene procedurou Farba.');
writeln('Vnutornou premennou TDEL sa da nastavit rychlost otvarania');
writeln('okien.');
priklad;
writeln('tdel:=30;');
writeln('Farba(Blue,Yellow);');
writeln('open_win(60,7,80,11,'+chr(39)+'Okno 1'+chr(39)+',1);');
writeln('Farba(Green,Red);');
writeln('open_win(60,12,80,15,'+chr(39)+'Okno 2'+chr(39)+',2);');
writeln('Farba(Red,LightGray);');
writeln('open_win(60,16,80,19,'+chr(39)+'Okno 3'+chr(39)+',3);');
writeln('Farba(Blue,Yellow);');
writeln('open_win(60,20,80,23,'+chr(39)+'Okno 4'+chr(39)+',4);');
farba(blue,yellow);
open_win(60,7,80,11,'Okno 1',1);
farba(Green,Red);
open_win(60,12,80,15,'Okno 2',2);
farba(Red,LightGray);
open_win(60,16,80,19,'Okno 3',3);
farba(blue,yellow);
open_win(60,20,80,23,'Okno 4',4);
window(1,1,80,25);
farba(Black,White);gotoxy(1,23);
end;
'M':begin
repeat
writeln('function Otazka (x,y:integer;s1,s2,s3:string;col:byte;typ:byte): integer;');
writeln('--------------------------------------------------------------------------');
writeln('Polozenie otazky uzivatelovi.');
writeln('x,y - pozicia otazok na obrazovke.');
writeln('s1,s2,s3 - Tri moznosti, pricom ak sa jedna vynecha budu 2, atd.');
writeln('Farba aktualnej odpovede.');
writeln('typ - typ bity 1,2 urcuju aka ma mat uvodzovky');
writeln(' 3 ci ma byt byt zhusteny tvar, alebo rovnaky rozostup.');
writeln(' uvodzovky typ 2, nezhusteny tvar typ 1 potom typ:=2+1*4;');
writeln('Prve velke pismeno urcuje moznost stlacit CRTL+to pismeno.');
writeln('Uznava farby nastavene vo Farba.');
writeln;
writeln('Odpoved je 0=ESC, alebo poradove cislo odpovede.');
priklad;
writeln('Farba(Blue,Yellow);');
writeln('WriteXY(45,15,'+chr(39)+'Pokracovat ???'+chr(39)+');');
writeln('odpoved:=Otazka(40,17,'+chr(39)+'Ano'+chr(39)+','+chr(39)+'Nie'+chr(39)+
','+chr(39)+'osTan'+chr(39)+',Green,5);');
Farba(Blue,Yellow);
WriteXY(45,15,'Pokracovat ???');
i:=Otazka(40,17,'Ano','Nie','osTan',Green,5);
delay(500);
Window(1,1,80,25);
farba(Black,White);gotoxy(1,23);clrscr;
until (i in [0,1]);
end;
'N':begin
writeln('procedure Koniec (naz_prog,rok:string); ');
writeln('---------------------------------------');
writeln('Vypise efektne ako NC Software by atd. s nazvom NAZ_PROG');
writeln('a rokom vyrobi ROK.');
writeln('Pre pouzitie autora.');
priklad;
writeln('Koniec('+chr(39)+'Super UNIT'+chr(39)+','+chr(39)+'95'+chr(39)+');');
end;
'O':begin
writeln('procedure Clear_Keyb; ');
writeln('---------------------');
writeln('Zmaze buffer klavesnice, ak je naplneny znakmi.');
writeln('Moze sa stat, ze chcete, aby pred neakou otazkou na');
writeln('uziavtela bol buffer prazdny pouzite Clear_Keyb;');
priklad;
writeln('Farba(Blue,Yellow);');
writeln('WriteXY(45,15,'+chr(39)+'Pokracovat ???'+chr(39)+');');
writeln('Clear_Keyb');
writeln('odpoved:=Otazka(40,17,'+chr(39)+'Ano'+chr(39)+','+chr(39)+'Nie'+chr(39)+
','+chr(39)+'osTan'+chr(39)+',Green,5);');
end;
'P':begin
writeln('function Get_Znak (x,y:byte;farba:byte): byte; ');
writeln('---------------------------------------------------');
writeln('Vrati znak, ktory je na pozicii x,y.');
writeln('Jeho farbu v premennej farba.');
writeln('Farba- dolne 4 bity su podklad, horne 4 pismo.');
writeln('farba_pisma:=(Color div 16)/16; farba_podkladu:=Color mod 16;');
writeln('Pozor farba nemoze byt cislo, musi byt premenna.');
priklad;
writeln('znak:=Get_Znak(10,10,Color);');
end;
'R':begin
writeln('procedure Put_Znak (x,y,farba,znak:byte); ');
writeln('-----------------------------------------');
writeln('Inverzna procedure k Get_Znak.');
writeln('x,y je pozicia');
writeln('farba je farba znaku+podklad farba:=Blue*16+Yellow');
writeln('znak je Ord(znaku), ktory ma byt vypisovany.');
priklad;
writeln('Put_znak(70,10,Blue*16+Yellow,Ord('+chr(39)+'a'+chr(39)+'));');
Put_znak(70,10,Blue*16+Yellow,Ord('a'));
end;
'S':begin
writeln('procedure Zarad_Okno (win_pointer:win_poin;x1,y1,x2,y2:byte); ');
writeln('-------------------------------------------------------------');
writeln('Vyhradi miesto v pameti pre okno s Win_Pointer pre suradnice');
writeln('x1,y1,x2,y2.');
writeln('Tuto rutinku pouziva Get_Window.');
end;
'T':begin
writeln('function Get_Window (x1,y1,x2,y2:integer): integer; ');
writeln('----------------------------------------------------');
writeln('Zapamata si aktivne okno a jeho obsah a ulozi do pamate.');
writeln('Rozmeri okna su lavy -horny (x1,y1)');
writeln(' pravy-dolny (x2,y2)');
writeln;
writeln('Vrati identifikacne cislo (ICO) ake bolo oknu pridelene.');
writeln('Celkovy pocet okien je vo vnutornej premennej WIN_POCET.');
writeln;
writeln('Vo vnutornej premennej WIN_POCET je pocet okien ulozenych v pamati.');
priklad;
writeln('Farba(Blue,Yellow);');
writeln('open_win(60,7,80,11,'+chr(39)+'Okno 1'+chr(39)+',1);');
writeln('okno:=Get_Window(10,2,70,20);');
writeln('Key:=ReadKey;');
writeln('ClrScr;');
writeln('err:=Put_Window(okno,0,0,0,0);');
farba(Blue,Yellow);
open_win(60,7,80,11,'Okno 1',1);
i:=Get_Window(10,2,70,20);
window(1,1,80,25);farba(Black,White);
ch:=tReadKey;
ClrScr;
i:=Put_Window(i,0,0,0,0);
ch:=tReadKey;ch:=#13;
window(1,1,80,25);farba(Black,White);
gotoxy(1,23);
end;
'U':begin
writeln('function Put_Window (por:integer;xn1,yn1,xn2,yn2:integer): integer; ');
writeln('-----------------------------------------------------------');
writeln('Inverzna k Get_Window.');
writeln('Por - ake okno v roradi vykreslit.');
writeln('xn1,yn1 - su nove suradnice do laveho horneho rohu do ktoreho ma vykreslit.');
writeln('xn2,yn2 - je velkost aku ma zobrazit z osi x,y.');
writeln('0,0,0,0 - znamena v povodnych suradniciach.');
writeln;
writeln('Vrati hodnoty 1-nenasiel som take okno');
writeln(' 0-vykreslil som toto okno');
writeln;
writeln('Vo vnutornej premennej WIN_POCET je pocet okien ulozenych v pamati.');
priklad;
writeln('Farba(Blue,Yellow);');
writeln('open_win(60,7,80,11,'+chr(39)+'Okno 1'+chr(39)+',1);');
writeln('okno:=Get_Window(10,2,70,20);');
writeln('Key:=ReadKey;');
writeln('ClrScr;');
writeln('err:=Put_Window(okno,1,1,60,10);');
farba(Blue,Yellow);
open_win(60,7,80,11,'Okno 1',1);
i:=Get_Window(10,2,70,20);
window(1,1,80,25);farba(Black,White);
ch:=tReadKey;
ClrScr;
i:=Put_Window(i,1,1,60,10);
ch:=tReadKey;ch:=#13;
window(1,1,80,25);farba(Black,White);
gotoxy(1,23);
end;
'V':begin
writeln('function Vyrad_Okno (por:integer): integer; ');
writeln('--------------------------------------------');
writeln('Vyhodi okno s pamate s poradovim cislom POR.');
writeln('Pozor predtym nez ho vyhodi nevykresli ho.');
writeln('Preto, ak chcete vydiet okno dajte ho najprv vykreslit,');
writeln('az tak vyhodit s pamete.');
writeln('Autor odporuca vyhadzovat v opacnomn poradi ako boli zaradene,');
writeln('pretoze pamet sa uvolni az po VYRADeni posledneho okna.');
writeln;
writeln('Ak vrati hodnotu 0-znamena, ze uz bolo vyradene, alebo sa neda vyhodit.');
writeln(' <>0-uspesne vyradene toto okno');
writeln;
writeln('Vo vnutornej premennej WIN_POCET je pocet okien ulozenych v pamati.');
priklad;
writeln('err:=Vyrad_Okno(1);');
end;
'X':begin
writeln('procedure Rem_All_Win; ');
writeln('----------------------');
writeln('Procedura vyhodi vsetky okna s pamate a uvolni ju.');
end;
end;
if ch<>#27 then begin
writeln;
writeln('Koniec ESC. Spat stlac akukolvek klavesu.');
ch:=treadkey;
if ch=#27 then ch:=#13;
end;
until (ch=#27);
end;
begin
writeln;
writeln('Tento program pouziva UNIT od TRSEKa Prikaz help('+chr(39)+' '+chr(39)+'); pre pomoc');
writeln('adresa WORD:\Europe\Slovakia\Presov\Trnkov_18\Zdeno_Sekerak.programator');
delay(500);
ctrsek_b:=BLACK;
ctrsek_f:=WHITE;
save_win;
tdel:=30;
wfirst_pointer:=NIL;
win_pocet:=0;
end.