Смекни!
smekni.com

Розробка комп ютерних навчальних засобів з обраної предметної області (стр. 5 из 5)

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.