ПрИЛОЖЕНИЕ 2
пример
выполнения контрольной работы № 9
Алгоритмически контрольная
работа № 9 ничем не отличается от работы № 8.
Структура записи аналогична структуре,
данной в П.1.1. Но здесь необходимо
организовать базу данных в виде файла
записей, который можно дополнять, изменять
в любое время.
п.2.1. Структура базы данных «ТОВАРы»
 |
Доступ:
seek(ff, 0);
seek(ff,
i-1);
Рис. П.2.1. Файл
записей
ff : file of RecType
При обработке записей в
программе Work9 используется временный файл basa.tmp, который
при выходе из программы может быть
переписан (по специальному запросу) в
нужный файл базы данных для последующей
обработки и затем удален. Использование временного
файла позволяет производить необходимые
операции с базой данных и не портить уже
имеющиеся файлы баз данных. Файл записей
является типизированным файлом (см. Прил. 4 -
П.4.2 [5]), к которому реализован прямой доступ
с помощью стандартной процедуры Seek, а
затем чтение или запись через обычные
операторы Read и Write.
Кроме того, эта программа уже имеет солидные размеры и возникает необходимость расчленить ее на ряд независимых частей (модулей), которые выполняют свои конкретные функции. В данном случае созданы два модуля, один из которых реализует «жесткий» ввод разнообразных данных (целых, вещественных и строковых) с соответствующими сообщениями (Input), другой - контрольные функции при работе с файлами (File_Rec).
п.2.2. ЛИСТИНГ модуля input.pas
Unit Input;
Interface
{Интерфейсная часть -
заголовки процедур и функций}
{ Преобразование любого целочисленного типа в string }
Function
IntToStr(I: Longint) : String;
{Вывод сообщений Str1, Str2, начиная с позиции курсора X, Y}
Procedure
OutMessageXY(X,Y:Byte;Str1,Str2:String);
{Вывод Width пробелов цветом Color на фоне Fon
с восстановлением прежних атрибутов вывода TaOld
и
возвратом в начальную позицию курсора}
Procedure
OutPutString(Color, Fon, TaOld, Width: Byte);
{Функция выдачи сообщений об ошибках Message
при нарушении диапазона
[NumberMin .. NumberMax]
на вводе целочисленных значений элементов
полей записи}
Function
error(Message: string; NumberMin, NumberMax: LongInt):boolean;
{Функция выдачи сообщения об ошибке Mes
при
вводе вещественных значений элементов
полей записи}
Function
error1:boolean;
{Ввод строки символов
S с проверкой диапазона количества
символов
[1..LenNaimt] и со строкой приглашения Inv}
Procedure
InputString(Var S: String; LenNaimt: byte; Inv: String);
{Ввод целочисленных данных Number (ширина поля Width)
с проверкой диапазона [NumberMin .. NumberMax]
и со строкой приглашения Inv}
Procedure
InputNumber(Var Number: Real; NumberMin, NumberMax: LongInt;
Width: Byte; Inv: String);
{Ввод вещественных данных R (ширина поля Width)
с проверкой на допустимый символ и со строкой приглашения Inv}
Procedure
InputReal(Var R: Real; Width: Byte; Inv: String);
Implementation {Исполняемая
часть - реализация процедур и функций}
Uses
CRT;
Const
ErrMes=' Ошибка ввода!!! ';
MesNumb='Численное
значение должно быть в диапазоне ';
TaOld=15;
{Стандартный атрибут: белые символы на
черном фоне}
TaNew=Red+16*LightGray+Blink;{красный
цвет на сером фоне с мерцанием}
Color=Yellow;
{желтый цвет символов}
Fon
=Blue; {голубой
цвет фона}
Var
flag: boolean;
Function
IntToStr(I: Longint): String;
var
S: string[11];
begin
Str(I, S);
IntToStr := S;
end;
Procedure
OutMessageXY(X,Y:Byte;Str1,Str2:String);
Var Xcur, Ycur:
byte;
Begin
Xcur:=WHereX;
{запоминание текущей позиции курсора}
Ycur:=WHereY;
GotoXY(X, Y);
TextAttr:=TaNew;
Write(Str1,Str2);
TextAttr:=TaOld;
GotoXY(Xcur, Ycur); {восстановление
позиции курсора}
End;
Procedure
OutPutString(Color, Fon, TaOld, Width: Byte);
Var Str: String;
i, Xcur, Ycur: byte;
Begin
Xcur:=WHereX;
{запоминание текущей позиции курсора}
Ycur:=WHereY;
Str:='';
TextAttr:=Color+16*Fon; {установка
атрибута для вывода пробелов}
for
i:=1 to Width do Str:=Str + ' ';
Write(Str);
TextAttr:=TaOld; {восстановление
прежних атрибутов}
GotoXY(Xcur, Ycur); {восстановление
позиции курсора}
End;
Function
error(Message: string; NumberMin, NumberMax: LongInt):boolean;
Var Mes: string;
begin
error:=true;
if flag then
begin
Mes:=ErrMes + Message;
writeln(Mes, '[', NumberMin, '..', NumberMax,']');
error:=false;
end;
end;
Function
error1:boolean;
Var Mes: string;
begin
error1:=true;
if flag then
begin
Mes:=ErrMes + ' Введено НЕ число....';
writeln(Mes);
error1:=false;
end;
end;
Procedure
InputString(Var S: String; LenNaimt: byte; Inv: String);
Begin
repeat
flag:=false;
Write(Inv,'===>');
OutPutString(Color, Fon, TaOld, LenNaimt);
Readln(S);
if length(S)>LenNaimt then flag:=true;
until error('Количество символов в строке
должно быть в диапазоне ',1,LenNaimt);
End;
Procedure
InputNumber(Var Number: Real; NumberMin, NumberMax: LongInt;
Width: Byte; Inv: String);
Begin
repeat
flag:=false;
Write(Inv,'===>');
OutPutString(Color, Fon, TaOld, Width);
{$I-}
Readln(Number);
{$I+}
if IOResult<>0 then flag:=true
else if (Number<NumberMin) or (Number>NumberMax)
then flag:=true;
until error(MesNumb, NumberMin, NumberMax);
End;
Procedure
InputReal(Var R: Real; Width: Byte; Inv: String);
Begin
repeat
flag:=false;
Write(Inv,'===>');
OutPutString(Color, Fon, TaOld, Width);
{$I-}
Readln(R);
{$I+}
if IOResult<>0 then flag:=true;
until error1;
End;
end. {Конец модуля}
п.2.3. ЛИСТИНГ модуля File_Rec.pas
Unit
File_Rec;
Interface
{ Логическая функция
возвращает значение True, если файл FileName
существует,
иначе возвращает значение False. Если файл существует, то он закрывается. }
Function
FileExists(FileName: String): Boolean;
{Функция проверки существования файла записей FileName
с выдачей аварийного сообщения, если F=True}
Function
Pust(FileName: string; F: boolean):boolean;
{Процедура вывода на экран списка
файлов текущего каталога}
Procedure
DirCat;
Implementation
Uses
Input, Dos;
Const
NoFile='Файл
не существует!!! ';
PovtVvod='
Повторите ввод. ';
function
FileExists(FileName: String): Boolean;
var
F: file;
begin
{$I-}
Assign(F, FileName);
Reset(F);
Close(F);
{$I+}
FileExists := (IOResult = 0) and (FileName <> '');
end;
{ FileExists }
Function
Pust(FileName: string; F: boolean):boolean;
Var
D: SearchRec;
begin
Pust:=true;
FindFirst(FileName, AnyFile, D);
If DosError<>0 then
begin
Pust:=False;
if F then OutMessageXY(20,24,NoFile,PovtVvod);
end
end;
Procedure
DirCat;
Var
s : SearchRec;
i : Byte;
begin
FindFirst('*.*', AnyFile, s);
Writeln('
Список файлов текущего каталога');
Writeln;
While DosError=0 do
begin
i:=i+1;
if i<5 then write(s.Name:15)
else
begin
writeln(s.Name:15);
i:=0;
end;
FindNext(s)
end;
Writeln
end;
End.
п.2.4. ЛИСТИНГ ПРОГРАММЫ Work9.pas
{$A+,B-,D+,E+,F-,G-,I+,L+,N+,O-,P-,Q-,R-,S+,T-,V+,X+}
{$M
16384,0,655360}
program
Work9;
{
Вариант № 40.
Создать файл записей
в соответствии с заданной структурой.
Количество записей <=65535 (ограничено диапазоном переменной типа WORD).
Реализовать редактирование записей (изменение, добавление, удаление). Исходные данные должны вводиться с проверкой на область допустимых значений. Реализовать в соответствии со своим вариантом запрос: «Определить общее количество товара, поступившего за определенный год» и вывод содержимого записи по определенным ключам. Предусмотреть вывод всей базы данных на экран. Вся обработка базы данных должна происходить путем выбора соответствующего пункта из меню.
Результат (база данных) должен
запоминаться тоже в файле и быть доступен
для последующей (многократной) обработки. В
реализации должны быть предусмотрены
модули (TPU).
}
Uses
Crt, Dos, Input, File_Rec;
Const
LenNaimt=27;
{Максимальная длина наименования
товара}
BasaTmp='basa.tmp';
{Имя рабочего (временного) файла записей}
Enter='Нажмите
ENTER............';
Empty='';
EmptyFile='
Файл записей пуст. ';
NoFile='Файл
записей не существует!!! ';
Continue='Для
окончания операции введите ESC, для
продолжения - Enter';
CaseStr='Выберите
курсором нужный режим. ';
Konec='Работа
с базой данных закончена. ';
RecNotFound='Запись
НЕ найдена!!!! ';
Shure='Вы
уверены, что это нужная запись? (Y/N)';
Inv1='Ввод базы данных';
Inv2='Вывести
данные на экран';
Inv3='Вычислить
общее количество товаров за определенный
год';
Inv4='Вывести
содержимое записи по ключу';
Inv5='Добавить
запись';
Inv6='Изменить
запись';
Inv7='Удалить
запись';
FileL
=12; {Максимальная
длина файла в MS DOS}
YearMin=1990;
{Минимальный год}
YearMax=2000;
{Максимальный год}
Type
data=
record
day : byte;
year : word;
month : byte;
end;
RecType=
record
naimt : string[LenNaimt];
kolt : longint;
stoimt : real;
dmg : data;
end;
file1=file of RecType;
Var
mas: RecType;
ch: char;
flag: boolean;
MaxElem: word; {Ограничение
максимального количества записей}
ff,ff1:file1;
FileName: string[FileL];
{Процедура вывода верхней части
шапки таблицы }
Procedure
TopT;
begin
writeln('??? ??
?? ?????????????????????
??');
writeln('? Наименование ? Кол-во ? Стоимость? Год ? Месяц? День?');
writeln('??? ??
?? ???????????????????????
??');
end;
{Процедура вывода нижней части
шапки таблицы}
Procedure
EndT;
begin
write('??? ??
?? ??????????????????
????
?');
end;
{Процедура ввода значений элементов
полей записи}
Procedure
InputFields(var rec: RecType);
Var a: real;
s: String;
begin
InputString(S, LenNaimt, 'Наименование');
Rec.naimt:=s;
InputNumber(a,0,2147483647,10,'Количество');
Rec.kolt:=trunc(a);
InputReal(a,11,'Стоимость');
rec.stoimt:=a;
InputNumber(a,YearMin,YearMax,4,'Год');
rec.dmg.year:=trunc(a);
InputNumber(a,1,12,2,'Месяц');
rec.dmg.month:=trunc(a);
InputNumber(a,1,31,2,'День');
rec.dmg.day:=trunc(a);
end;
{Процедура вывода значений
элементов полей записи}
Procedure
OutputRec(rec: RecType);
begin
Write('?',Rec.naimt);
Gotoxy(29,Wherey);
Write('?',Rec.kolt:10);
Gotoxy(40,Wherey);
Write('?',Rec.stoimt:11:2);
Gotoxy(52,Wherey);
Write('?',Rec.dmg.year:5);
Gotoxy(58,Wherey);
Write('?',Rec.dmg.month:3);
Gotoxy(64,Wherey);
Write('?',Rec.dmg.day:3);
Gotoxy(69,Wherey);
Writeln('?');
end;
{Создание файла записей}
Procedure
InputRecord(var MaxElem: word);
Var
i: Word;
ch: Char;
mas: RecType;
begin
i:=0;
assign(ff,
BasaTmp); {Открыть
временный файл на запись}
rewrite(ff);
repeat
clrscr;
inc(i);
InputFields(mas);
write(ff, mas);
OutMessageXY(12,23,Continue,Empty);
ch:=Readkey;
until ch=#27;
close(ff);
MaxElem:=i;
end;
{Вывод записей из временного файла записей}
Procedure
OutRecord(Var MaxElem: word);
Var i : Word;
mas: RecType;
begin
clrscr;
if Pust (BasaTmp, False) then
begin
assign(ff1,BasaTmp); {Открыть
временный файл на чтение}
reset(ff1);
TopT;
i:=0;
While not Eof(ff1) do
begin
seek(ff1,i);
read(ff1,mas);
OutputRec(mas);
i:=i+1;
end;
EndT;
OutMessageXY(20,24,Empty,Enter);
MaxElem:=i;
close(ff1);
end
else OutMessageXY(20,24,NoFile,Enter);
readln;
end;
Procedure
Zapros1;
Var a, Sum:
Real;
god, i: Word;
mas: RecType;
begin
Clrscr;
if Pust(BasaTmp, False)or(MaxElem<>0)
then
begin
Writeln('Вычислить общее количество
товаров за определенный год');
InputNumber(a,YearMin,YearMax,4,'Год');
god:=trunc(a);
sum:=0;
TopT;
assign(ff, BasaTmp); {Открыть временный файл
на чтение}
reset(ff);
i:=1;
while not Eof(ff) do
begin
seek(ff,i-1);
read(ff, mas);
if mas.dmg.year=god then
begin
sum:=sum + mas.kolt;
OutputRec(mas);
end;
i:=i+1;
end;
EndT;
Writeln;
if sum<>0 then
begin
Writeln('Суммарное количество товара за ',god,'
год составляет ',sum:12:0);
OutMessageXY(20,24,Empty,Enter);
end
else OutMessageXY(10,24,RecNotFound,Enter);
end
else OutMessageXY(20,24,NoFile,Enter);
readln;
end;
Procedure
KeyRec;
var ch: char;
r, st :Real;
f,f1 :Boolean;
Num, J, god : Word;
Str: String;
mas: RecType;
Label
1;
begin
repeat
f:=true;
clrscr;
if not Pust(BasaTmp, False)or(MaxElem=0) then
begin
OutMessageXY(20,24,NoFile,Enter);
Readln;
Exit;
end;
writeln('Вывести содержимое записи по ключу');
writeln('1: номер
записи');
writeln('2: наименование
товара');
writeln('3: стоимость
товара');
writeln('4: год поступления товара');
Writeln;
Writeln('Введите нужный ключ');
ch:=Readkey;
case ch of
'1': begin
InputNumber(r,1,MaxElem,2,' Введите
номер записи');
Num:=trunc(r);
end;
'2': InputString(Str, LenNaimt,' Введите
наименование товара');
'3': InputReal(st,11,' Введите стоимость товара');
'4': begin
InputNumber(r,YearMin,YearMax,4,' Введите год
поступления товара');
god:=trunc(r);
end
else
begin
Clrscr;
Writeln('Неизвестное значение ключа');
OutMessageXY(20,24,Empty,Enter);
readln;
f:=false;
end;
end;
until f;
f:=false; {Логический признак
нормального завершения работы}
f1:=false;
{Логический признак выдачи нужной
записи}
ClrScr;
TopT;
assign(ff,
BasaTmp); {Открыть
временный файл на чтение}
reset(ff);
if ch='1' then
begin
seek(ff,num-1);
read(ff, mas);
OutputRec(mas);
f:=true;
goto 1;
end;
for j:=1 to MaxElem do
begin
seek(ff,j-1);
read(ff, mas);
case ch of
'2': if str=mas.naimt then
begin
f:=true;
f1:=true;
end;
'3': if st=mas.stoimt then
begin
f:=true;
f1:=true;
end;
'4': if god=mas.dmg.year then
begin
f:=true;
f1:=true;
end;
end;
if f1 then
begin
OutputRec(mas);
f1:=false
end
end;
1:
if f then
begin
EndT;
OutMessageXY(20,24,Empty,Enter);
end
else OutMessageXY(10,24,RecNotFound,Enter);
Readln;
close(ff);
end;
{Процедура изменения (Flag=True)
или удаления (Flag=False)
записи из файла записей}
Procedure
ChangeDel(flag: boolean);
Var ch: char;
i, j: Word;
mas: RecType;
begin
if not Pust(BasaTmp, False) then
begin
OutMessageXY(10,24,EmptyFile,Enter);
Readln;
Exit
end;
repeat
clrscr;
if flag then writeln('Введите
номер изменяемой записи
[1..',MaxElem,']===>')
else writeln('Введите номер удаляемой записи [1..',MaxElem,']===>');
{$I-}
Readln(i);
{$I+}
until (IOResult=0)and(i>0) and (i<=MaxElem);
TopT;
assign(ff, BasaTmp); {Открыть временный файл}
reset(ff);
seek(ff,i-1);
read(ff, mas);
OutputRec(mas);
EndT;
writeln;
OutMessageXY(20,24,Shure,Empty);
ch:=ReadKey;
if (ch='y')or(ch='Y')then
begin
if flag then
begin
InputFields(mas) {Ввод всех полей заново для
изменяемой записи i};
seek(ff,i-1);
write(ff, mas);
end
else {удаление
записи i}
begin
for j:=i to MaxElem-1 do
begin
seek(ff, j); { Аналог
mas[j]:=mas[j+1];}
read(ff, mas);
seek(ff,j-1);
write(ff, mas);
end;
MaxElem:=MaxElem-1;
truncate(ff); {усечение
файла ff}
end;
if not flag then OutMessageXY(20,24,'Запись
удалена. ',Enter)
else OutMessageXY(20,24,'Запись
изменена. ',Enter);
readln;
close(ff);
end
end;
{Процедура добавления записи в файл
записей}
Procedure
AddRecord;
Label
1;
Var i, j: Word;
mas: RecType;
begin
repeat
clrscr;
Writeln('Введите номер добавляемой записи
[1..',MaxElem+1,']===>');
{$I-}
readln(i);
{$I+}
until (IOResult=0)and (i>0) and (i<=MaxElem+1);
MaxElem:=MaxElem+1;
1:
assign(ff, BasaTmp); {Открыть временный файл}
{$I-}
reset(ff);
{$I+}
if IOResult<>0 then
{Если файл
BasaTmp еще НЕ
существует}
begin
Rewrite(ff); {Создаем временный файл
BasaTmp}
Close(ff);
goto
1; {повторяем
еще раз, - файл BasaTmp уже существует}
end;
for j:=MaxElem downto i+1 do {перепись
всех элементов от
i+1 до MaxElem}
begin
seek(ff,j-2); { Аналог
mas[j]:=mas[j-1];}
read(ff, mas);
seek(ff,j-1);
write(ff, mas);
end;
InputFields(mas);
{Ввод добавляемой записи}
seek(ff,i-1);
write(ff, mas);
OutMessageXY(20,24,'Запись добавлена. ',Enter);
readln;
close(ff);
end;
{Процедура коррекции положения
курсора при движении стрелки вверх-вниз}
Procedure
UpDown(var Vari: integer; Im: byte);
begin
if ch=#0 then ch:=readkey;
case ch of
#72: begin
{стрелка вверх}
if vari=1 then vari:=im else
vari:=vari-1;
gotoxy(1,vari);
end;
#80: begin
{стрелка вниз}
if vari=im then vari:=1 else
vari:=vari+1;
gotoxy(1,vari);
end;
end;
end;
{Процедура создания базы данных}
Procedure
CreateDB (Var MaxElem: word);
var i, j: word;
Str: String;
mas: RecType;
begin
Clrscr;
writeln('1-
Использовать существующий файл базы данных');
writeln('2-
Создать новый файл базы данных с клавиатуры
');
OutMessageXY(25,24,'Введите
нужный ключ. ',Empty);
repeat
{$I-}
readln(i);
{$I+}
until (IoResult=0) and ((i=1) or (i=2));
case i of
1: begin
Clrscr;
DirCat;
Repeat
InputString(Str, FileL,' Введите
имя файла
базы данных');
FileName:=Str;
until Pust(FileName, True);
assign(ff1, BasaTmp); {Открыть временный файл на запись}
rewrite(ff1);
assign(ff, FileName); {Открыть файл
FileName на чтение}
reset(ff);
j:=0;
While not eof(ff) do
begin
j:=j+1;
read(ff, mas);
write(ff1,mas);
end;
MaxElem:=j;
close(ff);
close(ff1);
end;
2 : InputRecord(MaxElem);
end;
end;
{Функция организации главного меню}
Function
MainMenu : boolean;
const i : integer=1; {начальное положение
курсора}
var k : char;
name : string;
j : word;
begin
MainMenu:=false;
clrscr;
Writeln(Inv1);
Writeln(Inv2);
Writeln(Inv3);
Writeln(Inv4);
Writeln(Inv5);
Writeln(Inv6);
Writeln(Inv7);
Writeln('Выход');
OutMessageXY(15,24,CaseStr,Enter);
Gotoxy(1,i);
repeat
ch:=readkey;
if( ch=#32) or (ch=#13)then
begin
case i of
1: CreateDB(MaxElem);
{Создать базу данных}
2: OutRecord(MaxElem);
{Вывести данные на экран}
3: Zapros1; {Вычислить
общее количество товаров за определенный
год}
4: KeyRec; {Вывести
содержимое записи по ключу}
5: AddRecord; {Добавить
запись}
6: ChangeDel(true); {Изменить запись}
7: ChangeDel(false); {Удалить
запись}
8: Begin {Выход}
Mainmenu:=true;
Clrscr;
if MaxElem<>0 then
Begin
Assign(ff1,BasaTmp); {Открыть
временный файл на чтение}
Reset(ff1);
Writeln('Сохранить базу данных? (Y/N)');
k:=ReadKey;
If (k='y') or (k='Y') then
begin
ClrScr;
DirCat;
InputString(Name, FileL, 'Введите имя файла для
сохранения базы данных');
Assign(ff, name);
Rewrite(ff);
For j:=1 to MaxElem do
Begin
Read(ff1,mas);
Write(ff, mas);
End;
Close(ff);
OutMessageXY(20,24,Konec,Enter);
readln;
end;
Close(ff1);
Erase(ff1); {Удаление временного файла}
End; { if MaxElem<>0}
Exit;
End; {Выход}
end; { case }
exit;
end { if( ch=#32) or (ch=#13)}
else UpDown(i,8);
until false;
end;
{Главная программа}
begin
clrscr;
MaxElem:=0;
repeat until MainMenu;
end.
