Информатика 2 сем / Учебник по языку Паскаль
.pdf
244 9.3 Пример программы реализующей файлы записей
MY=80;
X=27;
Y=10;
OUTCOD = '*';
type
TDate = Record d,m:byte; y:word; end;
Trec = Record f1:string[30]; f2:TDate; f3:string[30]; f4:TDate; f5:word; f6:string[70]; f7:string[30]; end;
TDB = file of Trec;
TZA = array[1..NZ]of string; TMA = array[1..NM]of string; TNF = array[1..NF]of string;
const
Z:TZA = ('Список новорожденных, отсортированный по датам рождения',
'Список новорожденных, зарегистрированных в определенный день',
'Данные о ребенке по данным о родителях', 'Выход');
M:TMA = ('Создание БД', 'Вывод БД',
'Добавление записей в БД', 'Удаление записей из БД', 'Корректировка сведений в БД', 'Запрос', 'Выход');
FLD:TNF = ('ФИО',
'Дата рождения', 'Место рождения', 'Дата регистрации',
'Номер записи в книге регистрации', 'Сведения о родителях', 'Свидетельство о рождении');
var F:TDB; R:Trec; C:Char;
D,i:Byte;
9. Записной тип данных. СУБД |
245 |
{процедура вывода титульного листа} procedure TitulnyList;
begin clrScr;
textbackground(COLOR1);
textcolor(COLOR2);
clrScr;
GotoXY(14,2);
write('ВОЛГОГРАДСКИЙ ГОСУДАРСТВЕННЫЙ ТЕХНИЧЕСКИЙ УНИВЕРСИТЕТ');
GotoXY(24,4);
write('КАФЕДРА "ВЫЧИСЛИТЕЛЬНАЯ ТЕХНИКА"'); GotoXY(32,8);
write('СЕМЕСТРОВАЯ РАБОТА'); GotoXY(45,16);
write('ВЫПОЛНИЛ СТУДЕНТ ГРУППЫ: ',group); GotoXY(45,17);
write(NAME);
GotoXY(45,19); write('ПРОВЕРИЛ:'); GotoXY(45,20); write('ПЕТРОВ А.Р.'); GotoXY(33,24); write('ВОЛГОГРАД, 2007'); readKey;
end;
{процедура вывода заголовка при вводе записи} procedure IFF(var R:Trec);
var k:integer; c:char;
begin clrScr;
write(FLD[1],' (',OUTCOD,' - конец ввода): '); readln(r.f1);
end;
{процедура ввода даты}
procedure InputDate(var D:TDate); begin
writeLn; write('День: '); readln(D.d); write('Месяц: '); readln(D.m); write('Год: '); readln(D.y);
end;
246 9.3 Пример программы реализующей файлы записей
{процедура ввода записи} procedure InputRecord(var R:Trec); begin
write(FLD[2],': '); InputDate(R.f2); write(FLD[3],': '); readln(R.f3); write(FLD[4],': '); InputDate(R.f4); write(FLD[5],': '); readln(R.f5); write(FLD[6],': '); readln(R.f6); write(FLD[7],': '); readln(R.f7);
end;
{процедура, которая вызывает ввод записи и проверяет признак конца ввода}
procedure CF(var F:TDB); begin
IFF(R);
while R.f1<>OUTCOD do begin
InputRecord(R);
write(F,R);
IFF(R);
end;
end;
{процедура, которая создает файл и производит вызов процедуры его заполнения}
procedure VV(var F:TDB); begin
clrScr;
rewrite(F);
CF(F);
close(F);
end;
{процедура, вывода экземпляра записи} procedure PrintRecord(R:Trec);
begin clrScr;
writeLn(FLD[1],': ',r.f1);
writeLn(FLD[2],': ',r.f2.d,'.',r.f2.m,'.',r.f2.y); writeLn(FLD[3],': ',r.f3);
writeLn(FLD[4],': ',r.f4.d,'.',r.f4.m,'.',r.f4.y); writeLn(FLD[5],': ',r.f5);
9. Записной тип данных. СУБД |
247 |
writeLn(FLD[6],': ',r.f6); writeLn(FLD[7],': ',r.f7);
end;
{процедура печати базы} procedure PrintBase(var F:TDB); begin
reset(F);
while not eof(F) do begin
read(F,R);
PrintRecord(R);
readKey;
end;
close(F);
end;
{процедура добавления записи} procedure AddRecords(var F:TDB); begin
clrScr;
reset(F);
seek(F,Filesize(F));
CF(F);
close(F);
end;
{процедура удаления записи} procedure DeleteRecords(var F:TDB); var
I:Longint; begin
reset(F);
while not eof(F) do begin
read(F,R);
PrintRecord(R); writeLn('Удалить ? (1-Да)'); C:=readKey;
if C='1' then begin
I:=filepos(F)-1; While not eof(f) do
begin read(F,R);
seek(F,filepos(F)-2); write(F,R); seek(F,filepos(F)+1);
end;
248 9.3 Пример программы реализующей файлы записей
seek(F,filesize(F)-1); truncate(F); seek(F,I);
end;
end;
close(F);
end;
{процедура корректировки записи} procedure CorrectRecords(var F:TDB); begin
reset(F);
while not eof(F) do begin
read(F,R);
PrintRecord(R); writeLn('Корректировать ? (1-Да)'); C:=readKey;
If C='1' then begin
IFF(R);
InputRecord(R); seek(F,Filepos(F)-1); write(F,R);
end;
end;
close(F);
end;
{процедура выделения цветом пункта меню} procedure SetLineColor(NP,NS: Byte); begin
if NP=NS then begin
textbackground(COLOR2);
textcolor(COLOR1); end
else begin
textbackground(COLOR1);
textcolor(COLOR2); end
end;
9. Записной тип данных. СУБД |
249 |
{функция меню запроса} function MenuZ(X,Y:Byte):byte; var k:Byte;
begin k:=1; repeat
textbackground(COLOR1);
textcolor(COLOR2);
clrScr;
for i:=1 to NZ do begin
GotoXY(X,Y+i-1);
SetLineColor(k,i);
write(Z[i]);
end;
C:=readKey; case Ord(C) of
72:begin
if k=1 then k:=NZ else k:=k-1
end;
80:begin
if k=NZ then k:=1 else k:=k+1
end;
end;
until Ord(C)=13; MenuZ:=k;
end;
{логическая функция сравнения полей записи} function Logic(r,r1:TRec):boolean;
begin Logic:=(r.f2.y>r1.f2.y) OR
(
(r.f2.y=r1.f2.y) AND (r.f2.m>r1.f2.m) ) OR
(
(r.f2.y=r1.f2.y) AND (r.f2.m=r1.f2.m) AND(r.f2.d>r1.f2.d) );
end;
250 9.3 Пример программы реализующей файлы записей
{процедура сортировки файла с записями} procedure SortFile(var f:TDB);
var r1:Trec; l:boolean;
begin repeat
reset(f);
L:=true;
read(f,r);
while NOT EOF(f) do begin
read(f,r1);
if Logic(r,r1) then begin
seek(f,filepos(f)-2); write(f,r1); write(f,r); l:=false;
end else
r:=r1;
end; until L; end;
{процедура формирования нового файла} procedure Z1(var F:TDB);
var g:tdb; begin
clrScr;
reset(f);
assign(g,'g.db');
rewrite(g);
while not EOF(f) do begin
read(f,r);
write(g,r);
end;
SortFile(g);
PrintBase(g);
end;