Пример 1. 5 begin { Элемент вставляется следующим в списке}

program Number_1_5;

uses Crt;

{Создать список студентов и найти среди них однофамильцев}

const {список альтернатив для работы меню}

alter:array[1..5] of string[30]=(

'1.Создать файл',

'2.Создать список',

'3.Сортировка ',

'4.Вывод однофамильцев',

'5.Выход из программы');

Type

list_d = record { Структура- запись }

Title: string[20]; { Фамилия }

Nm,Pt: string[15]; { Имя,отчество }

Number: integer; { Номер по порядку }

end;

ff=file of list_d;{список для сохранения исходных данных в файле, чтобы проще было отлаживать и проверять решение}

pEl_list = ^list; { Указатель на структуру - список }

list = record { Структура - список }

li: list_d;

next: pEl_list; {Ссылка на следующий элемент списка}

end;

var lp,pList,pStart: pEl_list;

f:ff;

li:list_d;

noswap: boolean;{Для проверки выполнения сортировки}

ch: char;{Для самого простого варианта чтения символов}

i,oi,kol: integer; {переменные для работы с меню}

procedure init;

Begin

pStart:=nil;

end;

procedure DeleteList;

{Уничтожаем список для того, чтобы освободить память при сохранении списка, допустим, в файле}

Begin

lp:=pStart;

while lp <> nil do begin

pList:=lp;

Dispose(pList); {Уничтожается очередной элемент списка}

lp:= lp^.Next; {Перемещаемся по списку}

end;

end; { DeleteList }

{-------------------------------}

procedure Insert_list(el: list_d);

begin { Элемент вставляется следующим в списке}

new(pList);

if pStart =nil then

Begin

with pList^ do

Begin

li.Title:=el.title;

li. Nm:=el.Nm;

li.Pt:=el.Pt;

li.Number:=el.Number;

next:=nil;

end;

pStart:=pList;{Запоминаем начало списка}

lp:=pList; {А это текущий элемент списка, при одном элементе в списке - это первый элемент списка}

End

Else

Begin

lp^.next:=pList;

with pList^ do

Begin

li.Title:=el.title;

li. Nm:=el.Nm;

li.Pt:=el.Pt;

li.Number:=el.Number;

next:=nil;

end;

lp:=pList;{Движение по списку обеспечено}

end;

end; { InsertEl }

{-------------------------------}

procedure SaveBase_in_file;

{ Сохранение введенных данных в файле позволяет не вводить одну и туже информацию}

Var

FileName: string[12];

k:char;

Begin

FileName:= 'Wnd.bas';

Assign(f, FileName);

Rewrite(f);

Repeat

With li do

Begin

write(' Вводите список: фамилия ');

Readln(title);

write(' Имя ');

readln(Nm);

write(' Отчество ');

readln(Pt);

write(' Номер ');

readln(Number);

end;

write(f,li);

writeln('Есть еще сведения для списка?');

readln(k);

until k='n';

Close(f);

Writeln('Данные сохранены. Нажмите любую клавишу...');

ReadKey;

end; { SaveBase_in_file}

procedure List_creat;

{Создание обычного списка при чтении данных из файла Файл по умолчанию устанавливается для решения задачи с любым произвольным именем }

Begin

Init;

Assign(f,'Wnd.bas');

reset(f);{Проверку наличия файла опускаем, предполагая уже известными эти действия }

While not eof(f) do

Begin

read(f,li);

Insert_list(li);

end;

end;

procedure List_displ;

{ Вывести полностью список на экран для проверки правильности записи и преобразований}

var i:integer;

Begin

i:=1;

lp:=pStart;

writeln('Список всех, имеющихся в файле ');

while lp<>nil do

Begin

write(i,' ');

write(lp^.li.title+' ');

write(lp^.li.Nm+' ');

write(lp^.li.Pt+' ');

writeln(lp^.li.Number);

lp:=lp^.next;

i:=i+1;

end;

end;{Список можно теперь увидеть на экране}

procedure List_equal;

{Алгоритм поиска однофамильцев используется для упорядоченного списка по фамилиям, но он будет пригоден и для произвольного списка}

var i:integer;p:boolean;

Begin

lp:=pStart;

pList:=lp;

i:=1;

while lp<>nil do

Begin

p:=true;

while (p and (pList<>nil)) do

Begin

if pList<>lp then

if lp^.li.Title=pList^.li.Title then

Begin

write(i,' ');

write(lp^.li.Title+' ');

write(lp^.li.Nm+' ');

write(lp^.li.Pt+' ');

writeln(lp^.li.Number);

i:=i+1;

p:=false;

end;

pList:=pList^.next;

end;

pList:=lp;

lp:=lp^.next;

end; {Просмотр списка начинается заново всегда со следующего элемента}

end; {конец поиска однофамильцев}

procedure Sort;

Var

p1, p2, temp: pEl_list;

tt:list;

Begin

if ((pStart = nil) or (pStart^.Next = nil)) then

exit;

Repeat

p1:= pStart;

p2:=p1^.next;

noswap:=true;

while (p2 <> nil) do

Begin

if (p1^.li.Title > p2^.li.Title) then

Begin

{сравниваем только поля фамилий в списке}

noswap:=false;

tt:= p1^;

p1^:= p2^;

p2^:= tt;

temp:= p1^.next;

p1^.next:= p2^.next;

p2^.next:= temp;

end;

p1:=p2;

p2:= p2^.Next;

end;

until noswap;

end;{Конец сортировки}

procedure redact(x1,y1,l,v:integer);

Begin

textbackground(2);

window(x1+2,y1+oi*2-1,x1+l+2,y1+oi*2-l);

clrscr;

write(alter[oi]);

textbackground(4);

window(x1+2,y1+v*2-i,x1+l+2,y1+v*2-l);

clrscr;

write(alter[v]);

end;

procedure dialog;

Begin

textbackground(1);

window(30,2,78,23);

clrscr;

end;

procedure alt(x1,y1,l:integer); {это только меню в текстовом режиме для выполнения всех действий в определенной последовательности}

var k:char;

Begin

i:=1;

oi:=2;

Repeat

dialog;

Repeat

if oi<>i then redact(x1,y1,l,i);

oi:=i;

k:=readkey;

if k=#0 then k:=readkey;