program menu;
uses
crt,
dos,
stek,
ocher,
spisok,
massiv1;
const
Count = 5;
rev_vid = $5;
norm_vid = $7;
border = 1;
type
menu_type = array[1..Count] of string;
procedure save_video (startx, starty, endx, endy: byte;
var buf_ptr: pointer);
var
r: registers;
size: word;
i, j, k: byte;
p: ^byte;
begin
size := 2 * (endx - startx + 1) * (endy - starty + 1);
getmem (buf_ptr, size);
k := 0;
for i := starty to endy do
begin
for j := startx to endx do
begin
gotoxy (j, i);
r.ah := 8;
r.bh := 0;
intr (16, r);
p := ptr (seg (buf_ptr^), ofs (buf_ptr^) + k);
p^ := r.al;
p := ptr (seg (buf_ptr^), ofs (buf_ptr^) + k + 1);
p^ := r.ah;
k := k + 2;
end;
end;
end;
procedure restore_video (startx, starty, endx, endy: byte;
var buf_ptr: pointer);
var
r: registers;
size: word;
i, j, k: byte;
p: ^byte;
begin
size := 2 * (endx - startx + 1) * (endy - starty + 1);
k := 0;
for i := starty to endy do
begin
for j := startx to endx do
begin
gotoxy (j, i);
r.ah := 9;
r.bh := 0;
r.cx := 1;
p := ptr (seg (buf_ptr^), ofs (buf_ptr^) + k);
r.al := p^;
p := ptr (seg (buf_ptr^), ofs (buf_ptr^) + k + 1);
r.bl := p^;
intr (16, r);
k := k + 2;
end;
end;
freemem (buf_ptr, size);
end;
procedure draw_border (startx, starty, endx, endy: byte);
var
i: byte;
begin
for i := startx + 1 to endx - 1 do
begin
gotoxy (i, starty);
Write (#196);
gotoxy (i, endy);
Write (#196);
end;
for i := starty + 1 to endy - 1 do
begin
gotoxy (startx, i);
Write (#179);
gotoxy (endx, i);
Write (#179);
end;
gotoxy (startx, starty);
Write (#218);
gotoxy (startx, endy);
Write (#192);
gotoxy (endx, starty);
Write (#191);
gotoxy (endx, endy);
Write (#217);
end;
procedure display_menu (var menu: menu_type; x, y, Count: byte);
var
i: byte;
begin
for i := 1 to Count do
begin
gotoxy (x + 1, y + 1);
writeln (menu[i]);
y := y + 1;
end;
end;
procedure write_video (X, Y: byte; p: string; attrib: byte; S1: byte);
var
r: registers;
i, j: byte;
begin
j := 1;
for i := X + 1 to X + S1 do
begin
gotoXY (i, y);
r.ah := 9;
r.bh := 0;
r.cx := 1;
if i <= X + length (p) then
begin
r.al := Ord (p[j]);
end
else
begin
r.al := Ord (' ');
end;
j := j + 1;
r.bl := attrib;
intr ($10, r);
end;
end;
function get_resp (x, y, Count: byte; var menu: menu_type;
var keys: string; select_len: byte): shortint;
var
arrow_choice, key_choice: integer;
f: boolean;
ch: char;
border: byte;
men: menu_type;
begin
arrow_choice := 1;
write_video (x, y + 1, menu[arrow_choice], rev_vid, select_len);
while 1 < 2 do
begin
while not keypressed do
begin
end;
ch := readkey;
if ch = #0 then
begin
f := True;
ch := readkey;
end
else
begin
f := False;
end;
gotoxy (x, y + arrow_choice);
write_video (X, Y + arrow_choice, menu[arrow_choice], norm_vid, select_len);
if not f then
begin
Key_choice := pos (upcase (ch), keys);
if Key_choice > 0 then
begin
get_resp := key_choice;
arrow_choice := Key_choice;
end
else
begin
case ch of
#13:
begin
get_resp := arrow_choice;
end;
' ':
begin
get_resp := arrow_choice + 1;
end;
#27:
begin
get_resp := -1;
end;
end;
end;
break;
end
else
begin
case ch of
#72:
begin
arrow_choice := arrow_choice - 1;
end;
#80:
begin
arrow_choice := arrow_choice + 1;
end;
end;
end;
if arrow_choice > Count then
begin
arrow_choice := 1;
end;
if arrow_choice = 0 then
begin
arrow_choice := Count;
end;
write_video (X, Y + arrow_choice, menu[arrow_choice], rev_vid, select_len);
end;
end;
function popup (var menu: menu_type; var keys: string; Count, X, Y, border: byte): shortint;
var
i, len, endX, endY, choice: byte;
pBuf: pointer;
begin
if (y > 24) or (y < 0) or (x > 79) or (x < 0) then
begin
writeln ('Vihod za predeli ekrana');
popup := -2;
halt (1);
end;
len := 0;
for i := 1 to Count do
begin
if length (menu[i]) > len then
begin
len := length (menu[i]);
end;
end;
endX := Len + x + 1;
endY := Count + Y + 1;
if (endY > 24) or (endX > 79) then
begin
Writeln ('Vihod za predeli ekrana');
popup := -2;
halt (1);
end;
save_video (X, Y, endX, endY, pbuf);
if border = 1 then
begin
draw_border (X, Y, endX, endY);
end;
display_menu (menu, X, Y, Count);
choice := get_resp (X, Y, Count, menu, keys, len);
restore_video (X, Y, endX, endY, pbuf);
popup := choice;
end;
var
a: integer;
keys: string;
i, x, y: byte;
men, men1, men2, men4: menu_type;
begin
clrscr;
men[1] := 'V Stek ';
men[2] := 'R Ochered ';
men[3] := 'O obrabotka';
men[4] := 'V vivod';
men[5] := 'E exit';
men1[1] := 'K klaviatura ';
men1[2] := 'F fail ';
men2[1] := 'D Dobavit';
men2[2] := 'I Izmenit';
men2[3] := 'U Udalit';
men4[1] := 'Monitor (M)';
men4[2] := 'File (F)';
repeat
clrscr;
keys := 'VROVE';
a := popup (men, keys, Count, 7, 7, border);
case a of
1:
begin
clrscr;
keys := 'KF';
a := popup (men1, keys, 2, 5, 5, border);
case a of
1:
begin
clrscr;
stek_vvod;
stek_vivod;
stek_dobav;
stek_vivod;
stek_search;
stek_vivod;
stek_udal;
stek_vivod;
readkey;
end;
2:
begin
writeln ('Vvv imya faila');
readkey;
end;
end;
end;
2:
begin
clrscr;
keys := 'DIU';
a := popup (men2, keys, 3, 5, 5, border);
case a of
1:
begin
writeln (' dobavit`');
readkey;
end;
2:
begin
writeln ('izmenit`');
readkey;
end;
3:
begin
writeln (' udalit`');
readkey;
end;
end;
begin
clrscr;
keys := 'DIU';
a := popup (men2, keys, 3, 5, 5, 1);
case a of
1:
begin
writeln ('Vi vibrali dobavit`');
readkey;
end;
2:
begin
writeln ('Vi vibrali izmenit`');
readkey;
end;
3:
begin
writeln ('Vi vibrali udalit`');
readkey;
end;
end;
end;
end;
3:
begin
writeln ('Vi vibrali obrabotku');
readkey;
end;
4:
begin
clrscr;
keys := 'MF';
a := popup (men4, keys, 2, 5, 5, 1);
case a of
1:
begin
writeln ('Vi vibrali monitor');
readkey;
end;
2:
begin
writeln ('Vi vibrali fail');
readkey;
end;
end;
end;
end;
until (a = 5) or (a = -1);
end.
{ men2[1]:='Dobavit` (D)';
men2[2]:='Izmenit` (I)';
men2[3]:='Udalit` (U)';
men4[1]:='Monitor (M)';
men4[2]:='File (F)';}
слава богу, мне это не нужно заставлять работать, просто выучить хуиту, которая в процедурах
P. S. Кто-то сказал «под кат»?