1. Розв'язок системи лінійних алгебраїчних рівнянь Ax=b методом Гаусса.
program SLAU;
uses crt;
const size=30; {максимально припустима розмірність}
type matrix=array [1..size,1..size+1] of real;
type vector=array [1..size] of real;
function Getnumber (s:string; a,b:real):real;
{уведення числа з інтервалу a,b. Якщо a=b, то число будь-яке}
var n:real;
begin
repeat
write (s);
{$I-}readln (n);{$I+}
if (Ioresult<>0) then writeln ('Уведене не число!')
else if (a<b) and ((n<a) or (n>b)) then
writeln ('Число не в інтервалі від ',a,' до ',b)
else break;
until false;
Getnumber:=n;
end;
procedure Getmatrix (n,m:integer; var a:matrix); {уведення матриці}
var i,j:integer; si,sj: string [3];
begin
for i:=1 to n do begin
str (i,si);
for j:=1 to m do begin
str (j,sj);
a[i,j]:=Getnumber ('a['+si+','+sj+']=',0,0);
end;
end;
end;
procedure Getvector (n:integer; var a:vector); {уведення вектора}
var i:integer; si:string [3];
begin
for i:=1 to n do begin
str (i,si);
a[i]:=Getnumber ('b['+si+']=',0,0);
end;
end;
procedure Putvector (n:integer; var a:vector); {вивід вектора}
var i:integer;
begin
writeln;
for i:=1 to n do writeln (a[i]:10:3);
end;
procedure MV_Mult (n,m:integer;var a:matrix;var x,b:vector);
{множення матриці на вектор}
var i,j:integer;
begin
for i:=1 to n do begin
b[i]:=0;
for j:=1 to m do b[i]:=b[i]+a[i,j]*x[j];
end;
end;
function Gauss (n:integer; var a:matrix; var x:vector):boolean;
{метод Гаусса розв'язку СЛАУ}
{a - розширена матриця системи}
const eps=1e-6; {точність розрахунків}
var i,j,k:integer;
r,s:real;
begin
for k:=1 to n do begin {перестановка для діагональної переваги}
s:=a[k,k];
j:=k;
for i:=k+1 to n do begin
r:=a[i,k];
if abs(r)>abs(s) then begin
s:=r;
j:=i;
end;
end;
if abs(s)<eps then begin {нульовий визначник, немає розв'язку}
Gauss:=false;
exit;
end;
if j<>k then
for i:=k to n+1 do begin
r:=a[k,i];
a[k,i]:=a[j,i];
a[j,i]:=r;
end; {прямий хід методу}
for j:=k+1 to n+1 do a[k,j]:=a[k,j]/s;
for i:=k+1 to n do begin
r:=a[i,k];
for j:=k+1 to n+1 do a[i,j]:=a[i,j]-a[k,j]*r;
end;
end;
if abs(s)>eps then begin {зворотний хід}
for i:=n downto 1 do begin
s:=a[i,n+1];
for j:=i+1 to n do s:=s-a[i,j]*x[j];
x[i]:=s;
end;
Gauss:=true;
end
else Gauss:=false;
end;
var a,a1:matrix;
x,b,b1:vector;
n,i,j:integer;
begin
n:=trunc(Getnumber ('Уведіть розмірність матриці: ',2,size));
Getmatrix (n,n,a);
writeln ('Уведення правої частини:');
Getvector (n,b);
for i:=1 to n do begin {робимо розширену матрицю}
for j:=1 to n do a1[i,j]:=a[i,j];
a1[i,n+1]:=b[i];
end;
if Gauss (n,a1,x)=true then begin
write ('Розв'язок:');
Putvector (n,x);
write ('Перевірка:');
MV_Mult (n,n,a,x,b1);
Putvector (n,b1);
end
else write ('Розв'язку немає');
reset (input); readln;
end.
2. Процедурно-орієнтована реалізація завдання сортування одномірного масиву по зростанню
program Sort;
const size=100;
type vector=array [1..size] of real;
procedure Getarray (var n:integer; var a:vector);
var i:integer;
begin
repeat
writeln ('Уведіть розмірність масиву:');
{$I-}readln (n); {$I+}
if (n<2) or (n>size) then writeln ('Розмірність повинна бути від 2 до ',size);
until (n>1) and (n<size);
for i:=1 to n do begin
write (i,' елемент=');
readln (a[i]);
end;
end;
procedure Putarray (n:integer; var a:vector);
var i:integer;
begin
writeln;
for i:=1 to n do writeln (a[i]:10:3);
end;
procedure Sortarray (n:integer; var a:vector);
var i,j:integer;
buf:real;
begin
for i:=1 to n do
for j:=i+1 to n do if a[i]>a[j] then begin
buf:=a[i]; a[i]:=a[j]; a[j]:=buf;
end;
end;
var a:vector;
n:integer;
begin
Getarray (n,a);
Sortarray (n,a);
write ('Відсортований масив:');
Putarray (n,a);
end.
3. Обчислення всіх мінорів другого порядку у квадратній матриці
program Minor2_Count;
const Size=10;
type Matrix= array [1..Size,1..Size] of real;
function Minor2 (n:integer; i,j,l,k:integer; a:matrix):real;
begin
Minor2:=a[i,j]*a[l,k]-a[l,j]*a[i,k];
end;
procedure Input2 (var n:integer; maxn:integer; var a:matrix);
var i,j:integer;
begin
repeat
writeln;
write ('Уведіть розмірність матриці ( від 2 до ',Size,' включно):');
readln (n);
until (n>1) and (n<Size);
for i:=1 to n do begin
writeln;
write ('Уведіть ',i,' рядок матриці:');
for j:=1 to n do read (a[i,j]);
end;
end;
var i,j,k,l,n:integer;
s:real;
a:matrix;
begin
Input2 (n,Size,a);
for i:=1 to n do
for j:=1 to n do
for l:=i+1 to n do
for k:=j+1 to n do begin
s:=Minor2 (n,i,j,l,k,a);
writeln;
writeln ('Мінор [',i,',',j,']');
writeln (' [',l,',',k,']=',s:8:3);
end;
end.
4. Навчальна база даних "Студенти".
type student = record {Визначення запису "Студент"}
name:string[20];
balls:array [1..4] of integer;
end;
const filename='students.dat'; {Ім'я бази даних}
var s:student; {Поточний запис}
f:file of student; {Файл бази даних}
kol,current:longint; {Кількість записів і поточний запис}
size:integer; {Розмір запису в байтах}
st1,st2:string; {Буферні рядки для даних}
procedure Warning (msg:string); { Повідомлення-Попередження}
begin
writeln;
writeln (msg);
write ('Натисніть Enter для продовження');
reset (input); readln;
end;
procedure out; {Закриття бази й вихід}
begin
close (f);
halt;
end;
procedure Error (msg:string);
{Повідомлення про помилку + вихід із програми}
begin
writeln;
writeln (msg);
write ('Натисніть Enter для виходу');
reset (input); readln;
out;
end;
procedure open; {відкрити, при необхідності створити файл записів}
begin
assign (f,filename);
repeat
{$I-} reset (f); {$I+}
if Ioresult <> 0 then begin
Warning ('Не можу відкрити файл '+filename+
'... Буде створений новий файл');
{$I-}rewrite (f);{$I+}
if Ioresult <> 0 then
Error ('Не можу створити файл! Перевірте права й стан поточного диска');
end
else break;
until false;
end;
procedure getsize (var kol:longint;var size:integer);
{Поверне поточне число записів kol і розмір записи в байтах size}
begin
reset (f);
size:=sizeof(student);
if filesize(f)=0 then kol:=0
else begin
Seek(F, Filesize(F));
kol:=filepos (f);
end;
end;
function getname (s:string):string;
{Переводить рядок у верхній регістр в обліком кирилиці DOS}
var i,l,c:integer;
begin
l:=length(s);
for i:=1 to l do begin
c:=Ord(s[i]);
if (c>=Ord('а')) and (c<=Ord('п')) then c:=c-32
else if (c>=Ord('р')) and (c<=Ord('я')) then c:=c-80;
s[i]:=Upcase(Chr(c));
end;
getname:=s;
end;
procedure prints;
{Допоміжна процедура друку - друкує поточну s}
var i:integer;
begin
write (getname(s.name),': ');
for i:=1 to 4 do begin
write (s.balls[i]);
if i<4 then write (',');
end;
writeln;
end;
procedure print (n:integer); {Вивести запис номер n (з перехід до неї)}
begin
seek (f,n-1);
read (f,s);
prints;
end;
procedure go (d:integer); {Перейти на d записів по базі}
begin
writeln;
write ('Поточний запис: ');
if current=0 then writeln ('немає')
else begin
writeln (current);
print (current);
end;
current:=current+d;
if current<1 then begin
Warning ('Не можу перейти на запис із номером менше 1');
if kol>0 then current:=1
else current:=0;
end
else if current>kol then begin
str (kol,st1);
Warning ('Не можу перейти на запис із номером більше '+st1);
current:=kol;
end
else begin
writeln ('Новий запис: ',current);
print (current);
end;
end;
procedure search; {Пошук запису в базі на прізвище}
var i,found,p:integer;
begin
if kol<1 then
Warning ('База порожня! Шукати нема чого')
else begin
writeln;
write ('Уведіть прізвище (частина прізвища) для пошуку, регістр символів кожної:');
reset (input);
readln (st1);
st1:=getname(st1);
seek (f,0);
found:=0;
for i:=0 to kol-1 do begin
read (f,s);
p:=pos(st1,getname(s.name));
if p>0 then begin
writeln ('Запис номер ',i+1);
prints;
found:=found+1;
if found mod 10 = 0 then Warning ('Пауза...');
{Пауза після виведення 10 знайдених}
end;
end;
if found=0 then Warning ('Нічого не знайдене...');
end;
end;
procedure add; {Додати запис у кінець бази}
var i,b:integer;
begin
repeat
writeln;
write ('Уведіть прізвище студента для додавання:');
reset (input);
readln (st1);
if length(st1)<1 then begin
Warning ('Занадто короткий рядок! Повторите введення');
continue;
end
else if length(st1)>20 then begin
Warning ('Занадто довгий рядок! Буде обрізана до 20 символів');
st1:=copy (st1,1,20);
end;
s.name:=st1;
break;
until false;
for i:=1 to 4 do begin
repeat
writeln; { варто було б передбачити можливість уведення не всіх оцінок}
write ('Уведіть оцінку ',i,' з 4:');
{$I-}readln (b);{$I+}
if (Ioresult<>0) or (b<2) or (b>5) then begin
Warning ('Невірне введення! Оцінка - це число від 2 до 5! Повторите.');
continue;
end
else begin
s.balls[i]:=b;
break;
end;
until false;
end;
seek (f,filesize(f));
write (f,s);
kol:=kol+1;
current:=kol;
end;
procedure delete; {Видалення поточного запису}
var f2:file of student;
i:integer;
begin
if kol<1 then
Warning ('База порожня! Видаляти нема чого')
else begin
assign (f2,'students.tmp');
{$I-}rewrite(f2);{$I+}
if Ioresult<>0 then begin
Warning ('Не можу відкрити новий файл для запису!'+#13+#10+
'Операція неможлива. Перевірте права доступу й поточний диск.');
Exit;
end;
seek (f,0);
for i:=0 to kol-1 do begin
if i+1<>current then begin {переписуємо всі записи, крім поточної}
read (f,s);
write (f2,s);
end;
end;
close (f); {закриваємо вихідну БД}
erase (f); {Видаляємо вихідну БД, перевірка Ioresult опущена!}
rename (f2,filename); {Перейменовуємо f2 в ім'я БД}
close (f2); {Закриваємо перейменований f2}
open; {Зв'язуємо БД із колишньої файлової змінної f}
kol:=kol-1;
if current>kol then current:=kol;
end;
end;
procedure sort; {сортування бази на прізвище студента}
var i,j:integer;
s2:student;
begin
if kol<2 then
Warning ('У базі немає 2-х записів! Сортувати нема чого')
else begin
for i:=0 to kol-2 do begin {Звичайне сортування}
seek (f,i); {тільки в навчальних цілях - працює неоптимально}
read (f,s); {і багато звертається до диска!}
for j:=i+1 to kol-1 do begin
seek (f,j);
read (f,s2);
if getname(s.name)>getname(s2.name) then begin
seek (f,i);
write (f,s2);
seek (f,j);
write (f,s);
s:=s2; {Після перестановки в s уже новий запис!}
end;
end;
end;
end;
end;
procedure edit; {редагування запису номер current}
var i,b:integer;
begin
if (kol<1) or (current<1) or (current>kol) then
Warning ('Невірний номер поточного запису! Не можу редагувати')
else begin
seek (f,current-1);
read (f,s);
repeat
writeln ('Запис номер ',current);
writeln ('Виберіть дію:');
writeln ('1. Прізвище (',s.name,')');
for i:=1 to 4 do
writeln (i+1,'. Оцінка ',i,' (',s.balls[i],')');
writeln ('0. Завершити редагування');
reset (input);
{$I-}readln (b);{$I+}
if (Ioresult<>0) or (b<0) or (b>5) then
Warning ('Невірне введення! Повторите')
else begin
if b=1 then begin
write ('Уведіть нове прізвище:'); { для простоти тут немає}
reset (input); readln (s.name); {перевірок коректності}
end
else if b=0 then break
else begin
write ('Уведіть нову оцінку:');
reset (input); readln (s.balls[b-1]);
end;
end;
until false;
seek (f,current-1); {Пишемо, навіть якщо запис не мінявся -}
write (f,s); {у реальних проектах так не роблять}
end;
end;
procedure menu; {Керування головним меню й виклик процедур}
var n:integer;
begin
repeat
writeln;
writeln ('Виберіть операцію:');
writeln ('1 - уперед');
writeln ('2 - назад');
writeln ('3 - пошук на прізвище');
writeln ('4 - додати в кінець');
writeln ('5 - вилучити поточну');
writeln ('6 - сортувати на прізвище');
writeln ('7 - початок бази');
writeln ('8 - кінець бази');
writeln ('9 - змінити поточну');
writeln ('0 - вихід');
reset (input);
{$I-}read (n);{$I+}
if (Ioresult<>0) or (n<0) or (n>9) then begin
Warning ('Невірне введення!');
continue;
end
else break;
until false;
case n of
1: go (1);
2: go (-1);
3: search;
4: add;
5: delete;
6: sort;
7: go (-(current-1));
8: go (kol-current);
9: edit;
0: out;
end;
end;
begin {Головна програма}
open;
getsize (kol,size);
str(kol,st1);
str(size,st2);
writeln;
writeln ('==============================');
writeln ('Навчальна база даних "Студенти"');
writeln ('==============================');
Warning ('Файл '+Filename+' відкритий'+#13+#10+
'Число записів='+st1+#13+#10+
'Розмір запису='+st2+#13+#10);
{+#13+#10 - додати до рядка символи повернення каретки й первода рядка}
if kol=0 then current:=0
else current:=1;
repeat
menu;
until false;
end.
5. Програма містить коди часто використовуваних клавіш і друкує їхній назви
uses Crt;
const ESC=#27; ENTER=#13; F1=#59; F10=#68; TAB=#9; SPACE=#32;
UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77; HOME=#71; END_=#79;
PAGE_UP=#73; PAGE_DN=#81;
var Ch:char;
begin
Clrscr;
repeat
Ch:=Upcase(Readkey);
case Ch of
'A'..'z': write ('Letter');
SPACE: write ('Space');
ENTER: write ('ENTER');
TAB: write ('TAB');
#0: begin
Ch:=Readkey;
case Ch of
F1: write ('F1'); F10: write ('F10');
LEFT: write ('LEFT'); RIGHT: write ('RIGHT');
UP: write ('UP'); DOWN: write ('DOWN');
HOME: write ('Home'); END_: write ('End');
PAGE_UP: write ('Pgup'); PAGE_DN: write ('Pgdn');
end;
end;
else begin
end;
end;
until Ch=ESC;
end.
6.1. Програма дозволяє стрілками рухати по екрану "приціл"
uses Crt;
{$V-} {відключили строгий контроль відповідності типів}
const ESC=#27; UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;
var Ch:char;
procedure Draw (x,y:integer;mode:boolean);
{mode визначає, намалювати або стерти}
var sprite:array [1..3] of string [3]; {"приціл", заданий масивом sprite}
i:integer;
begin
sprite[1]:='/|\';
sprite[2]:='-=-';
sprite[3]:='\|/';
if mode=true then textcolor (White)
else textcolor (Black);
for i:=y to y+2 do begin
gotoxy (x,i);
write (sprite[i-y+1]);
end;
gotoxy (x+1,y+1);
end;
procedure Status (n:integer; s:string);
{малює рядок статусу внизу або вгорі екрана}
begin
textcolor (Black); textbackground (White);
gotoxy (1,n); write (' ':79);
gotoxy (2,n); write (s);
textcolor (White); textbackground (Black);
end;
var x,y:integer;
begin
Textmode (CO80);
Status (1,'Приклад програми керування рухом!');
Status (25,'Стрілки - керування; Esc - вихід');
x:=10; y:=10;
repeat
Draw (x,y,true);
Ch:=Upcase(Readkey);
case Ch of
#0: begin
Ch:=Readkey;
Draw (x,y,false);
case Ch of
LEFT: if x>1 then x:=x-1;
RIGHT: if x<77 then x:=x+1;
UP: if y>2 then y:=y-1;
DOWN: if y<22 then y:=y+1;
end;
end;
end;
until Ch=ESC;
Clrscr;
end.
6.2. Ця версія програми 6.1 дозволяє "прицілу" продовжувати рух доти, поки він не "натрапить" на край екрана.
uses Crt;
{$V-}
const ESC=#27; UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;
{коди потрібних клавіш}
const goleft=1;goright=2;goup=3;godown=4;gostop=0;
{можливі напрямки руху}
const mydelay=1000; {затримка для функції Delay}
var Ch:char;
Lastdir:integer; {останній напрямок руху}
procedure Draw (x,y:integer;mode:boolean);
var sprite:array [1..3] of string [3];
i:integer;
begin
sprite[1]:='/|\';
sprite[2]:='-=-';
sprite[3]:='\|/';
if mode then textcolor (White)
else textcolor (Black);
for i:=y to y+2 do begin
gotoxy (x,i);
write (sprite[i-y+1]);
end;
gotoxy (x+1,y+1);
end;
procedure Status (n:integer; s:string);
begin
textcolor (Black); textbackground (White);
gotoxy (1,n); write (' ':79);
gotoxy (2,n); write (s);
textcolor (White); textbackground (Black);
end;
var x,y:integer;
begin
Clrscr;
Status (1,'Приклад-2 програми керування рухом!');
Status (25,'Стрілки - керування; Esc - вихід');
x:=10; y:=10; Lastdir:=goleft;
repeat {нескінченний цикл роботи програми}
repeat {цикл до натискання клавіші}
Draw (x,y,true);
Delay (mydelay); {а краще написати свою версію цієї функції}
Draw (x,y,false);
case Lastdir of
goleft:
if x>1 then Dec(x)
else begin
x:=1; Lastdir:=gostop;
end;
goright:
if x<77 then inc(x)
else begin
x:=77; Lastdir:=gostop;
end;
goup:
if y>2 then Dec(y)
else begin
y:=2; Lastdir:=gostop;
end;
godown:
if y<22 then inc(y)
else begin
y:=22; Lastdir:=gostop;
end;
end;
until Keypressed;
{обробка натискання клавіші}
Ch:=Upcase(Readkey);
case Ch of
#0: begin
Ch:=Readkey;
case Ch of
LEFT: Lastdir:=goleft;
RIGHT: Lastdir:=goright;
UP: Lastdir:=goup;
DOWN: Lastdir:=godown;
end;
end;
ESC: Halt;
end;
until false;
end.
7. Демо-програма для створення нескладного дворівневого меню користувача. Перевизначивши користувацьку частину програми, на її основі можна створити власний інтерфейс.
uses crt; { Використовуємо модуль Crt }
{ Глобальні дані: }
const maxmenu=2; {кількість меню}
maxpoints=3; {максимальна кількість пунктів}
var x1,x2,y: array [1..maxmenu] of integer;
{x1,x2- початок і кінець кожного меню, y- рядок початку кожного меню}
kolpoints, points: array [1..maxmenu] of integer;
{ Кількість пунктів і поточна пункти кожного меню }
text: array [1..maxmenu,1..maxpoints] of string[12];
{ Назви пунктів кожного меню }
txtcolor, textback, cursorback:integer; { Кольору тексту, тла, курсору}
mainhelp:string[80]; { Рядок допомоги головного меню }
procedure Drawmain (S:string);{ Очищає екран і малює рядок головного меню S }
begin Window (1,1,80,25); { Дозволяємо весь екран для виведення}
textcolor (txtcolor); textbackground (textback);
clrscr; gotoxy (1,1); write (S);
end;
procedure Drawhelp (S:string); { Виводить у нижньому рядку екрана підказку S }
var i:integer; begin
textcolor (txtcolor); textbackground (textback); gotoxy (1,25);
for i:=1 to 79 do write (' ');
gotoxy (1,25); write (S);
end;
procedure Doubleframe (x1,y1,x2,y2:integer; Header: string);
{ Процедура малює подвійною рамкою вікно із заголовком; x1,y1,x2,y2 - координати вікна;
header - заголовок вікна}
var i,j: integer;
begin gotoxy (x1,y1); { Ставимо курсор у лівий верхній кут}
write ('╔'); {Малюємо}
for i:=x1+1 to x2-1 do write('═'); {верхній рядок}
write ('╗'); {рамки}
for i:=y1+1 to y2-1 do begin {Перебираємо рядка усередині вікна}
gotoxy (x1,i); write('║'); {Ліва границя вікна}
for j:=x1+1 to x2-1 do write (' '); {Внутрішність вікна - пробіли}
write('║'); {Права границя}
end;
gotoxy (x1,y2); write('╚'); {Аналогічно}
for i:=x1+1 to x2-1 do write('═'); {малюємо нижній рядок}
write('╝'); {рамки}
gotoxy (x1+(x2-x1+1-length(Header)) div 2,y1);
{Ставимо курсор у середину верхнього рядка}
write (Header); {Виводимо заголовок}
gotoxy (x1+1,y1+1); {Ставимо курсор у лівий верхній кут нового вікна}
end;
procedure Clearframe (x1,y1,x2,y2:integer); { Стирає область на екрані, задану координатами }
var i,j:integer;
begin textbackground (textback);
for i:=y1 to y2 do begin
gotoxy (x1,i);
for j:=x1 to x2 do write (' ');
end;
end;
procedure Cursor (Menu,Point: integer; Action: boolean);
{ Подсвечивает (якщо Action=TRUE) або гасить пункт Point меню Menu }
begin textcolor (Txtcolor);
if Action=TRUE then textbackground (Cursorback)
else textbackground (Textback);
gotoxy (x1[Menu]+1,y[Menu]+Point);
write (Text[Menu][Point]);
end;
procedure Drawmenu (Menu:integer; Action: boolean);
{Малює меню з номером Menu, якщо Action=TRUE, інакше стирає меню}
var i:integer;
begin
if Action=TRUE then textcolor (Txtcolor)
else textcolor (Textback);
textbackground (Textback);
Doubleframe (x1[Menu],y[Menu],x2[Menu],y[Menu]+1+Kolpoints[Menu],'');
for i:=1 to Kolpoints[Menu] do begin
gotoxy (x1[Menu]+1, y[Menu]+i);
writeln (Text[Menu][i]);
end;
end;
{ Ч А С Т Ь, обумовлена користувачем}
procedure Init;{ Установка глобальних даних і початкова отрисовка }
begin
txtcolor:=YELLOW; textback:=BLUE; cursorback:=LIGHTCYAN;
kolpoints[1]:=2; kolpoints[2]:=1; {пунктів у кожному меню}
points[1]:=1; points[2]:=1; {обраний за замовчуванням у кожному меню}
x1[1]:=1; x2[1]:=9; y[1]:=2; text[1,1]:='Запуск'; text[1,2]:='Вихід ';
x1[2]:=9; x2[2]:=22; y[2]:=2; text[2,1]:=' Про програму';
Drawmain ('Файл Довідка');
Mainhelp:='ESC - Вихід із програми ENTER - вибір пункту меню Стрілки - переміщення';
Drawhelp(Mainhelp);
end;
procedure Work;{ Робоча процедура програми }
var i,kol:integer; ch:char;
begin
Drawhelp('Іде розрахунки...'); { Рядок статусу }
textcolor (LIGHTGRAY); { Вибираємо кольору для роботи у вікні }
textbackground (BLACK);
Doubleframe (2,2,78,24,' Розрахунки '); { Малюємо рамку для вікна }
Window (3,3,77,23); { Уся робота виконується у вікні }
{ Секція дій, виконуваних програмою: }
writeln;
write ('Уведіть число кроків: ');
{$I-}read (kol);{$I+} {На час уведення відключили контроль помилок!}
if Ioresult<>0 then writeln ('Помилка! Ви ввели не число')
else if kol>0 then begin
for i:=1 to kol do writeln ('Виконується крок ',i);
writeln ('Усе зроблене!');
end
else writeln ('Помилка! Число кроків повинне бути більше 0');
{ Відновлення вікна й вихід з робочої процедури }
Window (1,1,80,25); { Дозволяємо весь екран для виведення}
Drawhelp('Натисніть будь-яку клавішу...');
ch:=readkey;
Clearframe (2,2,78,24); { Стираємо вікно }
end;
procedure Out; { Виконує очищення екрана й вихід із програми }
begin
Textcolor (LIGHTGRAY); Textbackground (BLACK); Clrscr; Halt(0);
end;
procedure Help; { Виводить вікно з інформацією }
var ch:char;
begin
textcolor (Txtcolor); Textbackground (textback);
Doubleframe (24,10,56,13,' Про програму ');
Drawhelp ('Натисніть клавішу для продовження...');
gotoxy (25,11); writeln (' Демонстрація найпростішого меню');
gotoxy (25,12); write ( ' Новосибірськ, 1996');
ch:=readkey;
Clearframe (24,10,58,13);
end;
procedure Command (Menu,Point:integer);{ Викликає процедури після натискання ENTER у меню }
begin
if Menu=1 then begin
if Point=1 then Work
else if Point=2 then Out;
end
else begin
if Point=1 then Help;
end;
end;
{ ДО ПРО Н Е Ц частини користувача }
procedure Mainmenu (Point, Hormenu :integer); { Підтримує систему одноуровневых меню }
var ch: char;
funckey:boolean;
begin
Points[Hormenu]:=Point;
Drawmenu (Hormenu,TRUE);
repeat
Cursor (Hormenu,Points[Hormenu],TRUE);
ch:=readkey;
Cursor (Hormenu,Points[Hormenu],FALSE);
if ch=#0 then begin
funckey:=TRUE; ch:=readkey;
end
else funckey:=FALSE;
if funckey=TRUE then begin
Ch:=Upcase (ch);
if ch=#75 then begin { Стрілка вліво }
Drawmenu (Hormenu,FALSE); Hormenu:=Hormenu-1;
if (Hormenu<1) then Hormenu:=Maxmenu;
Drawmenu (Hormenu,TRUE);
end
else if Ch=#77 then begin { Стрілка вправо }
Drawmenu (Hormenu,FALSE); Hormenu:=Hormenu+1;
if (Hormenu>Maxmenu) then Hormenu:=1;
Drawmenu (Hormenu,TRUE);
end
else if ch=#72 then begin { Стрілка нагору }
Points[Hormenu]:=Points[Hormenu]-1;
if Points[Hormenu]<1 then Points[Hormenu]:=Kolpoints[Hormenu];
end
else if Ch=#80 then begin { Стрілка вниз }
Points[Hormenu]:=Points[Hormenu]+1;
if (Points[Hormenu]>Kolpoints[Hormenu]) then Points[Hormenu]:=1;
end;
end
else if ch=#13 then begin { Клавіша ENTER }
Drawmenu (Hormenu,FALSE);
Command (Hormenu,Points[Hormenu]);
Drawmenu (Hormenu,TRUE);
Drawhelp (Mainhelp);
end;
until (ch=#27) and (funckey=FALSE); { Поки не натиснута клавіша ESC }
end;
{ Основна програма }
begin
Init;
Mainmenu (1,1);
Out;
end.
8. Найпростіший "генератор" програми на Паскалі. Із вхідного файлу, що містить текст, генерується Паскаль-Програма для листания цього тексту.
program Str2Pas;
uses Crt;
label 10,20;
var Ch:char;
Str:string;
I,J,Len,Count:word;
Infile,Outfile:text;
procedure Error (Ernum:char);
begin
case Ernum of
#1:
Writeln (' Запускайте цю програму із двома параметрами -',#13,#10,
' іменами вхідного й вихідного файлу.',#13,#10,
' У вхідному файлі повинен утримуватися текст,',#13,#10,
' у звичайному Ascii-Форматі,',#13,#10,
' у вихідному буде програма на Паскалі для його листания');
#2:
Writeln (' Не можу відкрити вхідний файл!');
#3:
Writeln (' Не можу відкрити вихідний файл!');
else Writeln (' Невідома помилка!');
end;
Halt;
end;
begin
if Paramcount<>2 then Error (#1);
Assign (Infile,Paramstr(1));
Reset (Infile);
if (Ioresult<>0) then Error (#2);
Assign (Outfile,Paramstr(2));
Rewrite (Outfile);
if (Ioresult<>0) then Error (#3);
{ Вписати заголовок програми }
Writeln (Outfile,'uses Crt;');
Write (Outfile,'const Colstr=');
{ Довідатися число рядків тексту }
Count:=0;
while not Eof (Infile) do begin
Readln (Infile,Str);
Count:=Count+1;
end;
Reset (Infile);
Writeln (Outfile,Count,';');
{ Наступний за розмірністю сегмент програми: }
Writeln (Outfile,'var Ch:char;');
Writeln (Outfile,' List:boolean;');
Writeln (Outfile,' I,Start,Endstr:word;');
Writeln (Outfile,' ptext:array [1..Colstr] of string;');
Writeln (Outfile,'begin');
{ Рядка текста, що листаемого: }
for I:=1 to Count do begin
Len:=0;
repeat
if (Eof (Infile)=TRUE) then goto 10;
Read (Infile,Ch);
if Ch=#39 then begin
Len:=Len+1; Str[Len]:=#39; Len:=Len+1; Str[Len]:=#39;
end
else if Ch=#13 then begin
Read (Infile,Ch);
if (Ch=#10) then goto 10
else goto 20;
end
else begin
20:
Len:=Len+1; Str[Len]:=Ch;
end;
until False;
10:
Write (Outfile,' ptext[',I,']:=''');
for J:=1 to Len do Write (Outfile,Str[J]);
Writeln (Outfile,''';');
end;
{ Сегмент програми }
Writeln (Outfile,' Textcolor (Yellow);');
Writeln (Outfile,' Textbackground (Blue);');
Writeln (Outfile,' List:=TRUE; Start:=1;');
{ Останній рядок на екрані: }
if (Count>25) then Writeln (Outfile,' Endstr:=25;')
else Writeln (Outfile,' Endstr:=Colstr;');
Writeln (Outfile,' repeat');
Writeln (Outfile,' if (List=TRUE) then begin');
Writeln (Outfile,' Clrscr;');
Writeln (Outfile,' for I:=Start to Endstr-1 do Write (ptext[I],#13,#10);');
Writeln (Outfile,' Write (ptext[Endstr]);');
Writeln (Outfile,' List:=FALSE;');
Writeln (Outfile,' end;');
Writeln (Outfile,' Ch:=Readkey;');
Writeln (Outfile,' if Ch= #0 then begin');
Writeln (Outfile,' Ch:=Readkey;');
Writeln (Outfile,' case Ch of');
Writeln (Outfile,' #72: begin');
Writeln (Outfile,' if Start>1 then begin');
Writeln (Outfile,' Start:=Start-1;');
Writeln (Outfile,' Endstr:=Endstr-1;');
Writeln (Outfile,' List:=TRUE;');
Writeln (Outfile,' end;');
Writeln (Outfile,' end;');
Writeln (Outfile,' #80: begin');
Writeln (Outfile,' if Endstr<Colstr then begin');
Writeln (Outfile,' Start:=Start+1;');
Writeln (Outfile,' Endstr:=Endstr+1;');
Writeln (Outfile,' List:=TRUE;');
Writeln (Outfile,' end;');
Writeln (Outfile,' end;');
{ Листание Pgup і Pgdn }
if (Count>25) then begin
Writeln (Outfile,' #73: begin');
Writeln (Outfile,' if Start>1 then begin');
Writeln (Outfile,' Start:=1; Endstr:=25;');
Writeln (Outfile,' List:=TRUE;');
Writeln (Outfile,' end;');
Writeln (Outfile,' end;');
Writeln (Outfile,' #81: begin');
Writeln (Outfile,' if Endstr<Colstr then begin');
Writeln (Outfile,' Start:=Colstr-24; Endstr:=Colstr;');
Writeln (Outfile,' List:=TRUE;');
Writeln (Outfile,' end;');
Writeln (Outfile,' end;');
end;
{ Заключний сегмент }
Writeln (Outfile,' else begin end;');
Writeln (Outfile,' end;');
Writeln (Outfile,' end');
Writeln (Outfile,' else begin');
Writeln (Outfile,' case ch of');
Writeln (Outfile,' #27: begin');
Writeln (Outfile,' Textcolor (Lightgray);');
Writeln (Outfile,' Textbackground (Black);');
Writeln (Outfile,' Clrscr;');
Writeln (Outfile,' Halt;');
Writeln (Outfile,' end;');
Writeln (Outfile,' else begin');
Writeln (Outfile,' end;');
Writeln (Outfile,' end;');
Writeln (Outfile,' end;');
Writeln (Outfile,' until False;');
Writeln (Outfile,'end.');
Close (Infile);
Close (Outfile);
Writeln ('OK.');
end.
9. Шаблон програми для роботи з матрицями й текстовими файлами
program Files;
{ Програма демонструє роботу з текстовими файлами й матрицями }
const rows=10;
cols=10;
type matrix=array [1..rows,1..cols] of real;
var f1,f2:text;
a,b:matrix;
Name1,Name2:string;
n,m:integer;
procedure Error (msg:string);
begin
Writeln;
Writeln (msg);
Writeln ('Натисніть Enter для виходу');
Reset (Input); Readln; Halt;
end;
procedure Readdim (var f:text; var n,m:integer);
{ Процедура читає з файлу f розмірності матриці:
n - число рядків, m - число стовпців.
Якщо n<0 або n>rows (число рядків) або m<0 або m>cols (число стовпців),
виведе повідомлення й перерве роботу.
}
var s:String;
begin
{$I-}read (f,n);{$I+}
if (Ioresult<>0) or (n<0) or (n>rows) then begin
str (rows,s);
Error ('Неприпустиме число рядків у файлі даних!'+#13+#10+
' повинне бути від 1 до '+s);
end;
{$I-}read (f,m);{$I+}
if (Ioresult<>0) or (m<0) or (m>cols) then begin
str (cols,s);
Error ('Неприпустиме число стовпців у файлі даних!'+#13+#10+
' повинне бути від 1 до '+s);
end;
end;
procedure Readmatrix (var f:text; n,m:integer; var a:matrix);
{ Процедура читає з файлу f матрицю a розмірністю n*m }
var i,j:integer;
er:boolean;
begin
er:=false;
for i:=1 to n do
for j:=1 to m do begin
{$I-}read (f,a[i,j]);{$I+}
if Ioresult<>0 then begin
er:=true;
a[i,j]:=0;
end;
end;
if er=true then begin
Writeln;
Writeln ('У прочитаних даних утримуються помилки!');
Writeln ('Відповідні елементи матриці були замінені нулями');
end;
end;
procedure Writematrix (var f:text; n,m:integer; var a:matrix);
{ Процедура пише у файл f матрицю a розмірністю n*m }
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (f,a[i,j]:11:4);
writeln (f);
end;
end;
procedure Proc1 (n,m:integer; var a,b:matrix);
{ Матрицю a[n,m] пише в матрицю b[n,m], міняючи знаки елементів }
var i,j:integer;
begin
for i:=1 to n do
for j:=1 to m do b[i,j]:=-a[i,j]
end;
begin
if Paramcount<1 then begin
Writeln ('Уведіть ім'я файлу для читання:');
Readln (Name1);
end
else Name1:=Paramstr(1);
if Paramcount<2 then begin
Writeln ('Уведіть ім'я файлу для запису:');
Readln (Name2);
end
else Name2:=Paramstr(2);
Assign (f1,Name1);
{$I-}Reset (f1);{$I+}
if Ioresult<>0 then Error ('Не можу відкрити файл '+Name1+' для читання');
Assign (f2,Name2);
{$I-}Rewrite (f2);{$I+}
if Ioresult<>0 then Error ('Не можу відкрити файл '+Name2+' для запису');
Readdim (f1,n,m);
Readmatrix (f1,n,m,a);
Proc1 (n,m,a,b);
Writematrix (f2,n,m,b);
Close (f1); Close (f2);
end.
10. Підрахунок кількості днів від уведеної дати до сьогоднішнього дня.
program Days;
uses Dos;
const mondays: array [1..12] of integer =
(31,28,31, 30,31,30, 31,31,30, 31,30,31);
var d,d1,d2,m1,m2,y1,y2:word;
function Leapyear (year:word):boolean;
begin
if (year mod 4 =0) and (year mod 100 <>0) or (year mod 400 =0) then
Leapyear:=TRUE
else Leapyear:=FALSE;
end;
function Correctdate (day,mon,year:integer):boolean;
var maxday:integer;
begin
if (year<0) or (mon<1) or (mon>12) or (day<1) then Correctdate:=FALSE
else begin
maxday:=mondays[mon];
if (Leapyear (year)=TRUE) and (mon=2) then maxday:=29;
if (day>maxday) then Correctdate:=FALSE
else Correctdate:=TRUE;
end;
end;
function Koldays (d1,m1,d2,m2,y:word):word;
var i,f,s:word;
begin
s:=0;
if m1=m2 then Koldays:=d2-d1
else for i:=m1 to m2 do begin
f:=mondays[i];
if (Leapyear (y)=TRUE) and (i=2) then f:=f+1;
if i=m1 then s:=s+(f-d1+1)
else if i=m2 then s:=s+d2
else s:=s+f;
Koldays:=s;
end;
end;
function Countdays (day1,mon1,year1,day2,mon2,year2:word):word;
var f,i:word;
begin
f:=0;
if year1=year2 then Countdays:=Koldays (day1,mon1,day2,mon2,year1)
else for i:=year1 to year2 do begin
if i=year1 then f:=Koldays (day1,mon1,31,12,year1)
else if i=year2 then f:=f+Koldays (1,1,day2,mon2,year2)-1
else f:=f+Koldays (1,1,31,12,i);
Countdays:=f;
end;
end;
begin
getdate (y2,m2,d2,d);
writeln ('Рік Вашого народження?');
readln (y1);
writeln ('Місяць Вашого народження?');
readln (m1);
writeln ('День Вашого народження?');
readln (d1);
if Correctdate (d1,m1,y1)=FALSE then begin
writeln ('Неприпустима дата!'); halt;
end;
if (y2<y1) or ( (y2=y1) and
( (m2<m1) or ( (m2=m1) and (d2<d1) ) ) ) then begin
writeln ('Уведена дата пізніше сьогоднішньої!'); halt;
end;
d:=Countdays (d1,m1,y1,d2,m2,y2);
writeln ('Кількість днів= ',d);
end.
11. Вихідний текст модуля для підтримки миші й тести модуля в графічному й текстовому режимі.
unit Mouse;
{Модуль для підтримки миші на Паскалі 6/7
Приклад використання - див. mousetst.pas у графіку,
mousetxt.pas у текстовому режимі 80*25
}
interface
var Mousepresent:Boolean;
{Функції модуля:}
function Mouseinit(var nb:Integer):Boolean;
{ Ініціалізація миші - викликати першої. Поверне true, якщо миша виявлена }
procedure Mouseshow; {Показати курсор миші}
procedure Mousehide; {Сховати курсор миші}
procedure Mouseread(var X,Y,bmask:integer); {Прочитати позицію миші
Поверне через x,y координати курсору ( для текстового режиму див. приклад),
через bmask - стан кнопок ( 0-відпущені, 1-натиснута ліва, 2-натиснута права,
3-натиснуто обидві) }
procedure Mousesetpos(x,y:Word); {Поставити курсор у зазначену позицію}
procedure Mouseminxmaxx(Minx,Maxx:Integer);
{Установити границі переміщення курсору по x}
procedure Mouseminymaxy(Miny,Maxy:Integer);
{Установити границі переміщення курсору по y}
procedure Setvideopage(Page:Integer); {Установити потрібну відеосторінку}
procedure Getvideopage(var Page:Integer); {Одержати номер відеосторінки}
function Mousegetb(bmask:Word;var Count,Lastx,Lasty:Word):Word;
procedure Mousekeypreset(var Key,Sost,X,Y:integer);
implementation
uses Dos;
var R: Registers;
Mi:Pointer;
function Mouseinit(var nb:Integer):Boolean;
begin
if Mousepresent then
begin
R.AX:=0;
Intr($33,R);
if R.AX=0 then
begin
nb:=0;
Mouseinit:=False
end
else
begin
nb:=R.AX;
Mouseinit:=True
end
end
else
begin
nb:=0;
Mouseinit:=False
end
end;
procedure Mouseshow;
begin
R.AX:=1;
Intr($33,R)
end;
procedure Mousehide;
begin
R.AX:=2;
Intr($33,R)
end;
procedure Mouseread(var X,Y,bmask:integer);
begin
R.AX:=3;
Intr($33,R);
X:=R.CX;
Y:=R.DX;
bmask:=R.BX
end;
procedure Mousesetpos(x,y:Word);
begin
R.AX:=4;
R.CX:=X;
R.DX:=Y;
Intr($33,R)
end;
function Mousegetb(bmask:Word;var Count,Lastx,Lasty:Word):Word;
begin
R.AX:=5;
R.BX:=bmask;Intr($33,R);
Count:=R.BX;
Lastx:=R.CX;
Lasty:=R.DX;
Mousegetb:=R.AX
end;
procedure Mouseminxmaxx(Minx,Maxx:Integer);
begin
R.AX:=7;
R.CX:=Minx;
R.DX:=Maxx;
Intr($33,R)
end;
procedure Mouseminymaxy(Miny,Maxy:Integer);
begin
R.AX:=8;
R.CX:=Miny;
R.DX:=Maxy;
Intr($33,R)
end;
procedure Setvideopage(Page:Integer);
begin
R.AX:=$1D;
R.BX:=Page;
Intr($33,R)
end;
procedure Getvideopage(var Page:Integer);
begin
R.AX:=$1E;
Intr($33,R);
Page:=R.BX;
end;
procedure Mousekeypreset(var Key,Sost,X,Y:integer);
begin
R.AX:=$6;
R.BX:=Key;
Intr($33,R);
Key:=R.AX;
Sost:=R.BX;
X:=R.CX;
Y:=R.DX;
end;
begin
Getintvec($33,Mi);
if Mi=nil then
Mousepresent:=False
else
if Byte(Mi)=$CE then
Mousepresent:=False
else
Mousepresent:=True
end.
program Mousetst; {Тест модуля mouse.pas у графічному режимі}
Uses Graph,Mouse,Crt;
Var grdriver : Integer;
grmode : Integer;
Errcode : Integer;
procedure init;
Begin
grdriver:=VGA;grmode:=Vgahi;
Initgraph(grdriver, grmode, '');
Errcode:=Graphresult;
If Errcode <> grok Then
Begin
Writeln('Помилка ініціалізації графіки:', Grapherrormsg(Errcode));
halt;
End;
end;
var n,x,y,x0,y0,b:integer;
s1,s2:string;
begin
init;
mouseinit(n);
mouseshow;
setfillstyle (Solidfill,black);
setcolor (white);
Settextjustify(Centertext, Centertext);
x0:=-1; y0:=-1;
repeat
mouseread (x,y,b);
if (x<>x0) or (y<>y0) then begin
str (x,s1); str (y,s2);
bar (getmaxx div 2-50, getmaxy-15,getmaxx div 2+50,getmaxy-5);
outtextxy (getmaxx div 2, getmaxy-10,s1+' '+s2);
x0:=x; y0:=y;
end;
until keypressed;
mousehide;
closegraph;
End.
program Mousetxt; {Тест модуля mouse.pas у текстовому режимі}
uses crt,mouse;
var n,x,y,b:integer;
n1,k,lastx,lasty:word;
begin
textmode(3);
mouseinit (n);
mouseshow;
repeat
mouseread (x,y,b);
gotoxy (1,25);
write ('x=',(x div 8 + 1):2,' y=',(y div 8 + 1):2,' b=',b:2);
until keypressed;
mousehide;
end.
12. Нескладна навчальна гра, що використовує власний файл ресурсів (спочатку лістинг утиліти для створення файлу ресурсів, потім лістинг програми).
{Зробити файл ресурсів Resfile з *.bmp поточної директорії,
