program
NZLAB_9r;
uses
crt;
const
desttxt='datatext.txt';
destdat='datatype.dat';
type
rec=record
family,name,surname:string;
ADR:string;
mark:string;
year:string;
color:string;
enige:string;
number:string;
end;
base=array[1..1]of
rec;
link=^base;
proc_out=procedure(var
all_base:link;var i:integer);
proc_in=procedure(var
all_base:link;var i:integer);
var
all_base:link;
i:integer;
k:boolean;
{$R-1}
{$F+}
procedure
card_out(var vsa_baza:link;var i:integer);
begin
with
all_base^[i] do begin
writeln('╔═══════════╤═══════════════════════════╗');
writeln('║Фамилия:
│',family:27,'║');
writeln('║Имя:
│',name:27,'║');
writeln('║Отчество:
│',surname:27,'║');
writeln('║Адрес:
│',adr:27,'║');
writeln('║Марка:
│',mark:27,'║');
writeln('║Год:
│',year:27,'║');
writeln('║Цвет:
│',color:27,'║');
writeln('║Движок:
│',enige:27,'║');
writeln('║Номер:
│',number:27,'║');
writeln('╚═══════════╧═══════════════════════════╝');
end;
end;
procedure
card_in(var all_base:link;var i:integer);
begin
if
all_base=nil then
begin
writeln('MEMORY
END');
readln;
halt;
end;
writeln('Вы
заполняете карточку №',i);
with
all_base^[i]
do
begin
write('Фамилия:
');
readln(family);
write('Имя:
');
readln(name);
write('Отчество:
');
readln(surname);
write('Адрес:
');
readln(adr);
write('Марка:
');
readln(mark);
write('Год
выпуска:
');
readln(year);
write('Цвет:
');
readln(color);
write('Двигатель:
');
readln(enige);
write('Гос.номер:
');
readln(number);
end;
end;
{$F-}
procedure
inrec(vvod_kartoshki:proc_in;card_out:proc_out;var i:integer;var
k:boolean);
var
x:char;
n,y:integer;
begin
y:=0;
clrscr;
writeln('Введите
количество вводимых записей');
readln(n);
n:=n+i;
y:=i+1;
while
y<=n
do
begin
clrscr;
card_in(all_base,y);
clrscr;
writeln('Проверьте
введенные данные и подтвердите ',
'занесение
в
базу:');
card_out(all_base,y);
y:=y+1;
writeln;
writeln('Сохранить
данные или поторить ввод?');
writeln('AnyKey-Сохранить,2-Повторить
ввод: ');
x:=readkey;
if
x='2' then
y:=y-1;
end;
k:=false;
i:=y-1;
end;
procedure
outrec(card_out:proc_out;var i:integer; var k:boolean);
var
x,y:integer;
begin
clrscr;
if
i=0 then
begin
writeln('В
базе
нет
элементов');
readln;
k:=false;
exit;
end;
y:=0;
repeat
clrscr;
y:=y+1;
writeln('Выводится
элемент
№',y);
card_out(all_base,y);
readln;
until
y>=i;
clrscr;
writeln('Элементы
закончились');
readln;
k:=false;
end;
procedure
search(card_out:proc_out;var i:integer; var k:boolean);
var
stroka:string;
x,y:integer;
z:char;
flag:boolean;
begin
clrscr;
if
i=0 then
begin
writeln('В
базе
нет
элементов');
readln;
k:=false;
exit;
end;
writeln('Введите
строку
для
поиска
(одно
слово
или
одно
поле)');
readln(stroka);
clrscr;
for
x:=1 to i do
begin
flag:=true;
with
all_base^[x]
do
begin
y:=pos(stroka,family);
if
y=0 then
y:=pos(stroka,name)
else
if
y=0 then
y:=pos(stroka,surname)
else
if
y=0 then
y:=pos(stroka,adr)
else
if
y=0 then
y:=pos(stroka,mark)
else
if
y=0 then
y:=pos(stroka,year)
else
if
y=0 then
y:=pos(stroka,color)
else
if
y=0 then
y:=pos(stroka,enige)
else
if
y=0 then
y:=pos(stroka,number)
else
if
y<>0 then
begin
writeln('Найдена
карточка
№',x);
card_out(all_base,x);
flag:=false;
writeln;
writeln('AnyKey-поиск,
2-выход
');
z:=readkey;
clrscr;
if
z='2' then exit;
end;
end;
end;
if
flag then
writeln('Ничего
не
найдено')
else
writeln('Поиск
успешно завершен');
readln;
k:=false;
end;
procedure
delete(card_out:proc_out;var i:integer; var k:boolean);
var
x,z:integer;
y:char;
begin
clrscr;
if
i=0 then
begin
writeln('В
базе нет элементов');
readln;
k:=false;
exit;
end;
write('Введите
номер
элемента:
');
readln(x);
if
(x>i)
or
(x<=0)
then
begin
clrscr;
writeln('Удаление
невозможно , элемента не существует');
readln;
k:=false;
exit;
end;
card_out(all_base,x);
writeln;
writeln('Вы
хотите
удалить
эту
запись?
(1-Да\AnyKey-Нет)');
y:=readkey;
if
y='1' then
begin
for
z:=x to i-1 do
all_base^[z]:=all_base^[z+1];
i:=i-1;
end;
k:=false;
end;
procedure
wr_dat_file(destdat:string;
i:integer;
all_base:link);
var
f:file
of rec;
k:integer;
begin
clrscr;
if
i=0 then
begin
writeln('Нечего
записывать');
readln;
exit;
end;
assign(f,destdat);
rewrite(f);
for
k:=1 to i do
write(f,all_base^[k]);
close(f);
writeln('Запись
в типизированный файл завершена');
readln;
end;
|