type student = record
{Определение записи "Студент"}
name:string[20];
balls:array [1..4] of integer;
end;

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.

Оценка - 1.4 (20)

2010-07-17 • Просмотров [ 5902 ]