Изучение алгоритмических языков высокого уровня было и остается важным элементом в подготовке специалиста, чья профессиональная деятельность связана с информационными технологиями.
Теоретический материал и многочисленные примеры программ, приведенные в этом пособии, позволяют автору рассчитывать, что оно окажется полезным для всех, кто приступает к изучению увлекательной науки программирования.
Приложение 1. Таблицы ASCII-кодов символов для операционных систем DOS и Windows
Чтобы понять, как хранится информация в ЭВМ, нам придется вспомнить ряд терминов.
Минимальная единица измерения информации -- один бит. Бит -- это двоичный разряд со значением "0" или "1". Очевидно, почему разработчики первых ЭВМ остановились на двоичной системе счисления. Числа в этой системе легче всего представить физически -- допустим, нулю соответствует состояние "не намагничено" участка магнитной ленты, а единице -- "намагничено", или нулю -- состояние "нет сигнала", а единице -- "есть сигнал" в некоторой линии связи.
Вся информация в компьютере хранится в числовой форме и двоичной системе счисления. Поскольку с помощью одного бита можно представить всего 2 различных значения, минимальной передаваемой или адресуемой единицей информации является байт, представляющий собой совокупность 8 бит. Более крупными единицами измерения данных являются килобайт (Кб) =1024 (210) байта, мегабайт (Мб) =1024 килобайта и гигабайт (Гб) =1024 мегабайта. Для ориентировки можно сказать, что если на странице текста помещается в среднем 2500 знаков, то 1 Мб -- это примерно 400 страниц, а 1 Гб -- 400 тысяч страниц.
Легко понять, сколько различных значений может быть представлено с помощью N бит -- это число равно 2N. Таким образом, в один байт "уместится" 28 = 256 различных значений.
Для обработки на компьютере вся нечисловая информация должна быть преобразована в числовую форму. Так, для компьютерной обработки текста каждая буква при вводе кодируется определенным числом, а при выводе на внешние устройства, такие как монитор или принтер, по кодам символов строятся соответствующие изображения букв. Соответствие между набором символом и кодирующими их числами называется кодировкой символов. Как правило, код символа хранится в одном байте, поэтому коды символов могут принимать значения от 0 до 255. Такие кодировки называются однобайтовыми. Основной символьный набор компьютера -- это стандартная для IBM-совместимых машин однобайтовая кодировка ANSI, называемая также ASCII-кодом (читается "аски-код").
В двухбайтовой кодировке Unicode(Юникод), предлагаемой в настоящее время в качестве общемирового стандарта, символ кодируется двумя байтами, таким образом, коды символов могут принимать значения от 0 до 65535=216 различных символов. В этой кодировке имеются коды для всех букв алфавитов множества языков, математических, декоративных символов и т. д.
На рис. П1 представлены две основные русскоязычные кодировки, известные как DOS-866 и Windows-1251. С первой работает среда Турбо-Паскаль и все программы русифицированных версий DOS, со второй -- все приложения русифицированных версий Windows. Чтобы узнать код символа, достаточно к числу десятков из первого столбца приписать число единиц из первой строки. Так, код буквы "Z" в обеих кодировках равен 90. Символы с кодами меньше 32 -- непечатаемые, это такие символы, как перевод строки, возврат каретки, табуляция, поэтому они не вошли в таблицу. Код пробела равен 32. Обратите внимание, что первые половины кодовых таблиц (символы с кодами меньше 128) совпадают как в этих двух кодировках, так и во всех остальных.
Рис. П1. Кодировки Dos и Windows
Приложение 2. Основные директивы компилятора Паскаля
{$A+} -- включить/выключить выравнивание по словам.
{$B+} -- включить/выключить полное вычисление булевых выражений.
{$С MOVEABLE DEMANDLOAD DISCARDABLE} --управление сегментом кода (только режимы Windows и Protected):
· MOVEABLE -- система может изменить положение сегмента кода в памяти;
· FIXED -- система не может изменить положение сегмента кода в памяти;
· PRELOAD -- сегмент кода загружается с началом исполнения программы;
· DEMANDLOAD -- сегмент кода загружается только при обращении;
· PERMANENT -- сегмент кода остается в памяти после загрузки;
· DISCARDABLE -- сегмент кода может быть выгружен после обращения.
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 (IoResult<>0) or (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;
{Переводит строку в верхний регистр
c учетом кириллицы 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; { Глобальные данные: }
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);
{ Процедура рисует двойной рамкой окно }
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 ( ' Новосибирск, НГАСУ');
ch:=readkey;
clearFrame (24,10,58,13);
end;
procedure command (Menu,Point:integer);
{Вызывает процедуры после выбора в меню }
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
('Запускайте с 2 параметрами -',#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.1. Исходный текст модуля для поддержки мыши.
unit Mouse;
{Примеры использования –
см. 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.
11.2. Тест модуля mouse.pas в графическом режиме (mousetst.pas).
