Работа со списком. Используем указатели

---

Пример 1. Программа выполняет следующие действия со списком:

• Выход из программы.
• Ввод или добавление элементов списка.
• Просмотр всех значений, хранящихся в списке.
• Удаление всего списка.
• Поиск заданного значения в списке.
• Найти и удалить найденный элемент.
• Вставить новое значения перед найденным.

---- Исходный текст программы ----
Program spisok4;
uses crt; {используются подпрограммы: clrscr, readkey и переменная textattr, описанные в CRT }
{ В этой программе при поиске элемента запоминается адрес переменной, указывающей на элемент.
 Такой подход позволяет более эффективно исключать найденный элемент из списка и вставлять
 новые элементы.}
type tip_info = integer;
PElement = ^TElement;
TElement = record
inf : tip_info;
next : PElement; 
end;

Tvar = ^PElement;

Tproc = procedure (var SomeElement: PElement );

const head: PElement = nil; {указатель на голову списка.
Используем ТИПИЗИРОВАННУЮ константу}
  count: integer = 0;
var ch1: char;  head0: PElement; spec1: tip_info;
 se,of1,ad: LongInt; Peremenn: TVar; 

procedure Insert1 (var SomeElement: PElement; info: tip_info);
{Вставка нового элемента в начало списка. Адрес элемента возвращается
через параметр-переменную SomeElement}
var bufi: tip_info; bufel: PElement;
begin
 New(bufel); 
 bufel^.inf := info;
 bufel^.next:= SomeElement;
 SomeElement:= bufel;
end;

procedure Browser(var SomeElement: PElement; Proc: TProc; messa: string);
{Перемещение по списку. Для каждого элемента выполняется
процедура Proc (параметр процедурного типа)}
var buf: PElement; se,of1,ad: longint;
begin inc(count);
  writeln(count,'  ',messa); writeln;
  head0:= SomeElement;
  while SomeElement <> Nil do
    begin buf:= SomeElement; 
      SomeElement:= SomeElement^.next;     
      Proc(buf);
    end;
end;

{$F+}
procedure ShowElement(var SomeElement: PElement );
{Показать информацию, хранимую элементом и его адрес}
var se,of1,ad,se2,of2,ad2: longint;
begin
  se:= seg(SomeElement^); of1:= ofs(SomeElement^); ad:= se*16 + of1;
  se2:= seg(SomeElement^.next^); of2:= ofs(SomeElement^.next^);
  ad2:= se2*16 + of2;
  writeln(' AdrNext= ',ad2:6,'  INF= ',SomeElement^.inf:6,
  ' SEG= ',se,' OFS= ',of1,' Адрес = ',ad);
end;
{$F-}

procedure InsertHead(var head1: PElement);
var info: tip_info; befor: longint;
begin
 writeln('Объем доступной памяти кучи (MemAvail)  = ',MemAvail);
 info:= 99;
   while info <> 0 do
   begin
     write ('Введи информацию (integer). Выход - 0 -> ');
     readln(info); if info = 0 then break;
     befor:= MemAvail;
     Insert1 (head1,info);
      writeln(
     'Вставил элемент - ',befor-MemAvail,' байт. Объем доступной памяти = ',MemAvail);
   end;
end;

procedure DeleteElem(var SomePeremenn: TVar);
{Удалить элемент}
var befor: longint; buf: PElement;
begin
  If SomePeremenn = Nil then
    begin
      writeln('Удалять нечего. Жми Enter'); 
     exit;
    end; 
  befor:= MemAvail; buf:= SomePeremenn^;
    SomePeremenn^:= SomePeremenn^^.next;
    writeln(' Удаляю элемент, info = ',buf^.inf,' Жми Enter');
  dispose(buf);
  writeln('Освободил ',MemAvail-befor,' байт. Теперь доступно: ',MemAvail);
end;

function FindElem { находит элемент, если задано содержимое поля inf }
(var HeadElement: PElement; { переменная-указатель на вершину (голову) списка }
 spec: tip_info  { образец для поиска (искомое значение) } ): TVar;
{возвращает указатель на переменную-указатель, хранящую адрес найденного элемента}
var buf, buf3: PElement; se1,of1,ad1: LongInt;
  Ukazik: TVar;
begin count:=0;
  buf:= HeadElement; Ukazik:= @HeadElement; 
  while buf <> Nil do
    begin 
      inc(count);
      if buf^.inf = spec then
        begin
          se1:=seg(buf^); of1:= ofs(buf^); ad1:= se1*16 + of1;
          writeln('FindElem: Элемент хранящий ',buf^.inf,' найден. Его номер = ',count,
          ' Адрес = ', ad1);
          FindElem := Ukazik; exit;
        end;
      buf:= buf^.next;  buf3:= Ukazik^; Ukazik := @buf3^.next;
    end;
    FindElem := Nil; writeln('Образец не найден');
end;

procedure DeleteList(var Head: PElement);
var buf,buf2: PElement; se,of2: LongInt; count,Ad: LongInt;
begin
buf := Head;
count := 0;
while buf <> Nil do
  begin inc(count);
    se:=seg(buf^);  of2:=ofs(buf^);
    Ad:= se*16+of2;  {Пример переполнения при вычислении выражения - если описать 
         se, ofs как integer или word, то здесь будет переполнение }
    write ('Удаляю элемент N ',count,' Адрес = ', Ad);
    buf2:= buf^.next; dispose(buf); buf:= buf2; 
    writeln(' Теперь свободно памяти = ', MemAvail);
  end;
  Head := Nil;
end;

begin {************* начало главной программы **************}
 textattr := $1b; clrscr; head0:= nil; head:= nil;
 Repeat
 se:= seg(head0^); of1:= ofs(Head0^) ; ad:= se*16 + of1;
 writeln(' ==== Свободной памяти в куче: ',MemAvail,
 ' байт. Head addr= ',ad,'  =====');
 writeln;
 Writeln('     Выбери операцию:');writeln;
 writeln(' 0 - Выход'); 
 writeln(' 1 - Ввод или добавление списка');
 writeln(' 2 - Просмотр списка');
 writeln(' 3 - Удаление списка');
 writeln(' 4 - Найти элемент');
 writeln(' 5 - Найти и удалить элемент');
 writeln(' 6 - Найти элемент и вставить перед ним новый элемент '); 
 writeln;
 writeln (' (Нажми:0 или 1 или 2 или 3 и т д.)');
 ch1 := readkey; clrscr;
  Case ch1 of
 '0': break;
 '1': begin head:= head0; InsertHead(head); head0:=head;
      end;
 '2': begin head:= head0;
       Browser(head, ShowElement,' ----- Просмотр списка -----');
      end;
 '3': begin head:= head0;
       DeleteList(head); head0 := head;
      end;
 '4': begin head:= head0;
        write('Образец для поиска -> '); readln(spec1);
        Peremenn := FindElem(head, spec1);
      end;
 '5': begin {head:= head0; felem:= nil; }
        write('Образец для поиска -> '); readln(spec1);
        Peremenn := FindElem(head0, spec1);
        {Peremenn^:=  Peremenn^^.next;}
        DeleteElem(Peremenn);
      end;
 '6': begin head:= head0; {felem:= nil;}
        write('Образец для поиска -> '); readln(spec1);
        Peremenn := FindElem(head, spec1);
        if Peremenn <> nil then 
          begin InsertHead(Peremenn^); head0:=head;
          end;
      end;
  end;  {case}
  until ch1 = '0';
end.