menu_insert_main(m, str, ' ');
mm:=false;
end else if str='' then begin
mm:=true;
inc(p1); if (p1>10) then error('max no of submenus: 10');
p2:=1;
end else begin
fmen[p1, p2]:=copy(str, 1, pos(' ', str)-1);
inc(p2); if (p2>10) then error('max no of items in submenu: 10');
menu_insert_sub(m, p1+1, copy(str, pos(' ', str)+1, 255), ' ');
end;
end;
end;
var
run: word;
extt: string;
begin
textattr:=7; clrscr;
menu_init(m);
menu_insert_main(m, 'ю', '‚');
menu_insert_sub(m, 1, 'Exit', 'x');
fillmenu;
repeat
keybar('Help', '', '', '', '', '', '', '', '', 'Menu');
run:=menu_run(m, 0, 3, 15, 0, 0, 3, 15, 0);
case hi(run) of
1: break;
2..10: begin
extt:=upcasing(copy(fmen[hi(run)-1, lo(run)],
pos('.', fmen[hi(run)-1, lo(run)])+1, 255));
if extt='STR' then showtext(fmen[hi(run)-1, lo(run)]);
if extt='EXE' then begin
textattr:=7;
clrscr;
SwapVectors;
Exec(fmen[hi(run)-1, lo(run)], '');
SwapVectors;
if DosError <> 0 then error('Dos error #'+strg(DosError));
readkey;
end;
end;
end;
until false;
menu_done(m);
textattr:=7; clrscr;
writeln('Program created as a cursova by');
writeln(' * Slawa Pidgorny. <slawa@queen.ukma.kiev.ua>');
writeln(' * Sveta Fiyalka. <svetaflk@queen.ukma.kiev.ua>');
writeln('using Turbo Pascal 7.0.');
end.
SMENU.PAS
unit smenu;
interface
const
max_of_main = 10;
max_of_item = 30;
type
menu = record
mains: integer;
current: integer;
item1: array [1..max_of_main] of record
text: string[max_of_item];
letter: char;
items: integer;
current: integer;
item2: array [1..10] of record
text: string[max_of_item];
letter: char;
able: boolean;
end;
end;
end;
procedure menu_init(var m: menu);
procedure menu_insert_main(var m: menu; s: string; c: char);
procedure menu_insert_sub(var m: menu; n: integer; s: string; c: char);
function menu_run(m: menu; c1, c2, c3, c4, c5, c6, c7, c8: byte): word;
procedure menu_done(m: menu);
implementation
uses
crt;
procedure Cursor(x1, x2: byte); assembler;
asm
mov ah, 1
mov ch, x1
mov cl, x2
int 10h
end;
function strings(a: integer): string;
var
s: string;
i: integer;
begin
s:='';
for i:=1 to a do begin
s:=s+' ';
end;
strings:=s;
end;
procedure colors(a, b: byte);
begin
textcolor(a); textbackground(b);
end;
procedure colour(a: byte);
begin
textattr:=a;
end;
procedure print(x, y: integer; c: byte; s: string);
begin
gotoxy(x, y);
colour(c);
write(s);
end;
procedure frame(x1, y1, x2, y2: byte; S: string; c1, c2: byte; Double: boolean);
var
i, k, Leng, High: byte;
begin
Leng:=x2-x1;
High:=y2-y1;
Window(x1, y1, x1+Leng, y1+High);
Colour(c1);
ClrScr;
Window(1, 1, 80, 25);
if Double=True then Print(x1, y1, c1, 'Й') else Print(x1, y1, c1, 'Ъ');
for i:=1 to Leng do
if Double=True then Print(x1+i, y1, c1, 'Н') else Print(x1+i, y1, c1, 'Д');
if Double=True then Print(x2+1, y1, c1, '»') else Print(x2+1, y1, c1, 'ї');
for i:=1 to High do begin
if Double=True then Print(x1, y1+i, c1, 'є') else Print(x1, y1+i, c1, 'і');
if Double=True then Print(x2+1, y1+i, c1, 'є') else Print(x2+1, y1+i, c1, 'і');
end;
if Double=True then Print(x1, y2, c1, 'И') else Print(x1, y2, c1, 'А');
for i:=1 to Leng do
if Double=True then Print(x1+i, y2, c1, 'Н') else Print(x1+i, y2, c1, 'Д');
if Double=True then Print(x2+1, y2, c1, 'ј') else Print(x2+1, y2, c1, 'Щ');
if S<>'' then Print(x1+(Leng div 2)-(Length(S) div 2), y1, c2, ' '+S+' ');
end;
procedure menu_init(var m: menu);
begin
m.mains:=0;
m.current:=1;
end;
procedure menu_insert_main(var m: menu; s: string; c: char);
begin
inc(m.mains);
m.item1[m.mains].text:=s;
m.item1[m.mains].letter:=c;
m.item1[m.mains].current:=1;
end;
procedure menu_insert_sub(var m: menu; n: integer; s: string; c: char);
begin
inc(m.item1[n].items);
m.item1[n].item2[m.item1[n].items].text:=s;
m.item1[n].item2[m.item1[n].items].letter:=c;
end;
function menu_run(m: menu; c1, c2, c3, c4, c5, c6, c7, c8: byte): word;
var
pos_tab: array[1..max_of_main] of record
x, l: integer;
end;
scr1: array[0..3999] of byte;
procedure screen_save; assembler;
asm
push ds
mov ax, 0B800h
mov ds, ax
xor si, si
mov ax, seg scr1
mov es, ax
mov di, offset scr1
mov cx, 1000
cld
db $66; rep movsw
pop ds
end;
procedure screen_restore; assembler;
asm
push ds
mov ax, seg scr1
mov ds, ax
mov si, offset scr1
mov ax, 0B800h
mov es, ax
xor di, di
mov cx, 1000
cld
db $66; rep movsw
pop ds
end;
procedure create_pos_tab;
var
i, p: integer;
begin
p:=2;
for i:=1 to m.mains do begin
pos_tab[i].x:=p;
inc(p, length(m.item1[i].text)+2);
end;
end;
procedure main_show(m: menu; sel: integer);
var
i: integer;
begin
gotoxy(1, 1);
colors(c1, c2);
clreol;
for i:=1 to m.mains do begin
if i=sel then begin
colors(c3, c4);
end else begin
colors(c1, c2);
end;
gotoxy(pos_tab[i].x, 1);
write(' '+m.item1[i].text+' ');
end;
end;
function sub_menu_max_len(m: menu; n: integer): integer;
var
i, max: integer;
begin
max:=0;
for i:=1 to m.item1[n].items do begin
if max<length(m.item1[n].item2[i].text) then begin
max:=length(m.item1[n].item2[i].text);
end;
end;
sub_menu_max_len:=max;
end;
procedure sub_show(m: menu; sel1, sel2: integer);
var
i: integer;
begin
frame(pos_tab[sel1].x, 2, 1+pos_tab[sel1].x+sub_menu_max_len(m, sel1)+1,
m.item1[sel1].items+3, '', c5+16*c6, c7+16*c8, false);
for i:=1 to m.item1[sel1].items do begin
if i=sel2 then begin
colors(c3, c4);
end else begin
colors(c1, c2);
end;
gotoxy(pos_tab[sel1].x+1, 2+i);
write(' '+m.item1[sel1].item2[i].text+' '+strings(
sub_menu_max_len(m, sel1)-length(m.item1[sel1].item2[i].text)));
end;
end;
var
main_menu_position: integer;
sub_menu_position: integer;
sub_menu_open: boolean;
ch: char;
saved_x, saved_y: byte;
saved_colors: byte;
begin
cursor($20, $20);
saved_colors:=textattr;
saved_x:=wherex;
saved_y:=wherey;
main_menu_position:=m.current;
sub_menu_open:=false;
create_pos_tab;
screen_save;
repeat
screen_restore;
main_show(m, main_menu_position);
if sub_menu_open then begin
sub_show(m, main_menu_position, sub_menu_position);
end;
ch:=readkey;
if ch=#0 then begin
ch:=readkey;
if ch=#75{Left} then begin
if main_menu_position>1 then begin
m.item1[main_menu_position].current:=sub_menu_position;
dec(main_menu_position);
sub_menu_position:=m.item1[main_menu_position].current;
end;
end;
if ch=#77{Right} then begin
if main_menu_position<m.mains then begin
m.item1[main_menu_position].current:=sub_menu_position;
inc(main_menu_position);
sub_menu_position:=m.item1[main_menu_position].current;
end;
end;
if sub_menu_open then begin
if ch=#72{Up} then begin
if sub_menu_position>1 then begin
dec(sub_menu_position);
end;
end;
if ch=#80{Down} then begin
if sub_menu_position<m.item1[main_menu_position].items then begin
inc(sub_menu_position);
end;
end;
end; {sub_menu_open}
end; {ch=#0}
if ch=#13{Enter} then begin
if not sub_menu_open then begin
sub_menu_open:=true;
sub_menu_position:=m.item1[main_menu_position].current;
end else begin
menu_run:=main_menu_position*256+sub_menu_position;
break;
end;
end;
if ch=#27{Esc} then begin
menu_run:=0;
break;
end;
until false;
screen_restore;
textattr:=saved_colors;
gotoxy(saved_x, saved_y);
cursor(6, 7);
end;
procedure menu_done(m: menu);
begin
end;
end.
TEXT2STR.PAS
type
str80 = string[80];
var
f1: text;
f2: file of str80;
str: string;
str2: str80;
begin
if paramcount<>2 then exit;
assign(f1, paramstr(1));
reset(f1);
assign(f2, paramstr(2));
rewrite(f2);
write('Processing');
while not eof(f1) do begin
readln(f1, str);
str2:=copy(str, 1, 80);
write(f2, str2);
write('.');
end;
writeln;
close(f2);
close(f1);
end.
CURSOV16.PAS
uses
crt;
procedure a1;
begin
textColor(14);
textBackground(3);
write('Slawa');
textAttr:=7;
writeLn;
end;
procedure a31; assembler;
asm
mov ah, 9 {function 9}
mov al, 'a' {char 'a'}
xor bh, bh {video page 0}
mov bl, 16*3+14 {color}
mov cx, 5 {print 5 times}
int 10h {printing}
end;
procedure a32;
const
str: array [0..6] of char ='slawa'+#13+#10;
begin
asm
push bp {push used registers to stack}
push es
mov ax, seg str {es is a segment register of text}
mov es, ax
mov bp, offset str {es:bp is an actual string location}
mov ah, 13h {funtion 13h}
mov al, 1 {only text}
mov bh, 0 {video page}
mov bl, 16*3+14 {color}
mov cx, 7 {chars' counter}
mov dh, 10 {coordinates}
mov dl, 10
int 10h {printing}
pop es {restore registers}
pop bp
end;
end;
procedure a4; assembler;
const
color: byte = 16*3+14; {color}
str: array [0..4] of char
= 'slawa'; {string to print}
strlen: word = 5; {length of that string}
asm
mov ax, 0B800h {mov es, 0B800h}
mov es, ax
mov cx, strlen {cx - counter of chars}
mov si, offset str {ds:si - text}
xor di, di {es:di - video memory}
@a:
lodsb {load byte from ds:si}
stosb {store byte to es:di}
mov al, color
stosb {store color to es:di}
loop @a {while there is more chars to print}
end;
begin
textattr:=7; clrscr; a1; readkey;
textattr:=7; clrscr; a31; writeln; textattr:=7; clreol; readkey;
textattr:=7; clrscr; a32; readkey;
textattr:=7; clrscr; a4; readkey;
end.
CURSOV26.PAS
uses crt, graph;
procedure a5;
var
aVGA, aVGALO: integer;
begin
aVGA:=VGA; aVGALO:=VGAHI;
initGraph(aVGA, aVGALO, ''); {entering video mode 640x480x16}
setFillStyle(1, 13);
bar(10, 10, 100, 100); {making a filled rectangle}
readkey; {press any key}
setPalette(13, 3); {palette changing}
end;
procedure a6; assembler;
asm
{palette changing}
mov ah, 10h {function 10h for palette operations}
mov al, ah {subfunct 10h for changin 1 palette color}
mov bx, 14 {14 color number}
mov bh, 10 {red 10}
mov ch, 40 {green 40}
mov cl, 30 {blue 30}
int 10h {changing}
end;
procedure a7; assembler;
const
n: byte = 14; {color}
r: byte = 63; {red}
g: byte = 23; {green}
b: byte = 25; {blue}
asm
mov dx, 3C8h {port #3C8h}
mov al, n {outing color number}
out dx, al
inc dx {port #3C9h}
mov al, r {outing red}
out dx, al
mov al, g {outing green}
out dx, al
mov al, b {outing blue}
out dx, al
end;
procedure tograph(a: word); assembler;
asm
{entering mode13h - 320x200x256}
mov ax, 13h
int 10h
{filling all the screen with 14th color}
mov ax, 0A000h
mov es, ax {mov es, 0A000h}
mov cx, 64000/2 {cx - counter}
xor di, di {begin of video memory is at 0A000:0}
cld {move forward}
mov ax, a {color to put}
rep stosw {filling}
end;
procedure totext; assembler;
asm
mov ax, 3 {changing video mode to text one}
int 10h
end;
begin
textattr:=7; clrscr; a5; readkey;
tograph(14+256*14);
readkey;
a6;
readkey;
a7;
readkey;
totext;
end.
CURSOV33.PAS
uses
crt;
procedure a8; assembler;
asm
mov ah, 11h {function 11h - bios font operations}
mov al, 11h {8x14}
mov bl, 0 {font plane}
int 10h {changing}
call readkey; {let you see the changes}
mov ah, 11h {function 11h - bios font operations}
mov al, 12h {8x8}
mov bl, 0 {font plane}
int 10h {changing}
call readkey; {let you see the changes}
mov ah, 11h {function 11h - bios font operations}
mov al, 14h {8x16}
mov bl, 0 {font plane}
int 10h {changing}
call readkey; {let you see the changes}
end;
begin
writeln('That''s a text mode font changing demonstration');
a8;
end.