Список адресов почтовых корреспонденций, построенный в виде списка с двумя связями
Ниже приведена простая программа для списка почтовых коррес-
понденций, построенного в виде списка с двойной связью. Здесь
весь список содержится в оперативной памяти. Однако, программа
может быть изменена для хранения списка на диске.
{простая программа для списка адресов почтовых корреспон-
денций, иллюстрирующая применение списков с двойной связью}
program mailing_list;
type
str80 = string[80];
AddrPointer = -address;
address = record
name: string[30];
street: string[40];
city: string[20];
state: string[2];
zip: string[9];
next: AddrPointer; { указатель на следующую запись }
prior: AddrPointer; { указатель на предыдущую запись }
end;
DataItem = address;
filtype = file of address;
var
t, t2: integer;
mlist: FilType;
start, last: AddrPointer;
done: boolean;
{ вызов меню }
function MenuSelect: char;
var
ch: char;
begin
Writeln('1. Enter names');
Writeln('2. Delete a name');
Writeln('3. Display the list');
Writeln('4. Search for a name');
Writeln('5. Save the list');
Writeln('6. Load the list');
Writeln('7. Quit');
repeat
Writeln;
Write('Enter your choice: ');
Readln(ch);
ch := UpCase(ch);
until (ch>='1') and (ch<='7')
MenuSelect := ch;
end;{ конец выбора по меню }
{ упорядоченная установка элементов в список с двойной связью }
function DSL_Store(info, start: AddrPointer;
var last: AddrPointer): AddrPointer;
{ вставка элементов в соответствующее место с сохранением
порядка }
var
old, top: AddrPointer;
done: boolean;
begin
top := start;
old := nil;
done := FALSE;
if start = nil then begin { первый элемент списка }
info^.next := nil;
last := info;
info^.prior :=nil;
DSL_Store := info;
end else
begin
while (start<>nil) and (not done) do
begin
if start^.name < info^.name then
begin
old := start;
start := start^.next;
end else
begin { вставка в середину }
if old <>nil then
begin
old^.next := info;
info^.next := start;
start^.prior := info;
info^.prior := old;
DSL_Store := top; { сохранение начала }
done := TRUE;
end else
begin
info^.next := start;{новый первый элемент }
info^.prior := nil;
DSL_Store := info;
done := TRUE;
end;
end;
end; { конец цикла }
if not done then begin
last^.next := info;
info^.next := nil;
info^.prior := last;
last := info;
DSL_Store := top; { сохранение начала }
end;
end;
end; { конец функции DSL_Store }
{ удалить элемент из списка с двойной связью }
function DL_Delete(start: AddrPointer
key: str[80]): AddrPointer
var
temp, temp2: AddrPointer
done: boolean;
begin
if star^.name = key then begin { первый элемент
списка }
DL_Delete := start^.next;
if temp^.next <> nil then
begin
temp := start^.next;
temp^.prior := nil;
end;
dispose(start);
end else
begin
done := FALSE;
temp := start^.next;
temp2 := start;
while (temp <> nil) and (not done) do
begin
if temp^.next <> nil then
temp^.next^.prior := temp2
done := TRUE
dispose(temp);
end else
begin
temp2 := temp;
temp := temp^.next;
end;
end;
DL_Delete := start; { начало не изменяется }
if not done then Writeln('not found');
end;
end; { конец функции DL_Delete }
{ удаление адреса из списка }
procedure remove;
var
name:str80;
begin
Writeln('Enter name to delete: ');
Readln(name);
start := DL_Delete(start,name);
end; { конец процедуры удаления адреса из списка }
procedure Enter;
var
info: AddrPointer;
done: boolean;
begin
done := FALSE;
repeat
new(info) { получить новую запись }
Write('Enter name: ');
Readln(info^.name);
if Length(info^.name)=0 then done := TRUE
else
begin
Write(Enter street: ');
Readln(info.street);
Write(Enter city: ');
Readln(info.city);
Write(Enter state: ');
Readln(info.state);
Write(Enter zip: ');
Readln(info.zip);
start := DSL_Store(info, start, last); { вставить
запись }
end;
until done;
end; { конец ввода }
{ вывести список }
procedure Display(start:AddrPointer);
begin
while start <> nil do begin
Writeln(start^.name);
Writeln(start^.street);
Writeln(start^.city);
Writeln(start^.state);
Writeln(start^.zip);
start := start^.next
Writeln;
end;
end;
{ найти элемент с адресом }
function Search(start: AddrPointer; name: str80):
AddrPointer;
var
done: boolean;
begin
done := FALSE
while (start <> nil) and (not done) do begin
if name = start^.name then begin
search := start;
done := TRUE;
end else
start := star^.next;
end;
if start = nil then search := nil; { нет в списке }
end; { конец поиска }
{ найти адрес по фамилии }
procedure Find;
var
loc: Addrpointer;
name: str80;
begin
Write('Enter name to find: ');
Readln(name);
loc := Search(start, name);
if loc <> nil then
begin
Writeln(loc^.name);
Writeln(loc^.street);
Writeln(loc^.city);
Writeln(loc^.state);
Writeln(loc^.zip);
end;
else Writeln('not in list')
Writeln;
end; { Find }
{ записать список на диск }
procedure Save(var f:FilType; start: AddrPointer):
begin
Writeln('saving file');
Rewrite(f);
while start <> nil do begin
write(f,start);
start := start^.next;
end;
end;
{ загрузить список с файла }
procedure Load(var f:FilType; start: AddrPointer):
AddrPointer;
var
temp, temp2: AddrPointer
first: boolean;
begin
Writeln('load file');
Reset(f);
while start <> nil do begin { освобождение памяти
при необходимости }
temp := start^.next
dispose(start);
start := temp;
end;
start := nil; last := nil;
if not eof(f) then begin
New(temp);
Read(i, temp^);
temp^.next := nil; temp^.prior:= nil;
load := temp; { указатель на начало списка }
end;
while not eof(f) do begin
New(temp2);
Read(i, temp2^);
temp^.next := temp2; { построить список }
temp2^.next := nil;
temp^.prior := temp2;
temp := temp2;
end;
last := temp2;
end; { конец загрузки }
begin
start := nil; { сначала список пустой }
last := nil;
done := FALSE;
Assign(mlist, 'mlistd.dat');
repeat
case MenuSelect of
'1': Enter;
'2': Remove;
'3': Display(start);
'4': Find;
'5': Save(mlist, start);
'6': start := Load(mlist, start);
'7': done := TRUE;
end;
until done=TRUE;
end. { конец программы }
