Операции с двунаправленными списками

program list;
 
type
   tData = integer;
   
   tPtr = ^tNode;
   
   tNode = record
      data: tData;
      next: tPtr;
      prev: tPtr;
   end;
   
   tList = tPtr;
 
var
   key: integer;//пункт меню
   l: tList;
 
procedure Error(message: string);//выдача сообщения об ошибке
begin
   writeln('*** Ошибка: ' + message );
   writeln;
end;
 
procedure Init(var l: tList);//инициализация  списка
begin
   l := nil;
end;
 
function NotEmpty(l: tList): Boolean;//список не пуст
begin
   NotEmpty := l <> nil;
end;
 
procedure Put(var l: tList; D: tData);
var
   p{, p1}: tPtr;
begin
   new(p);
   p^.data := D;
   p^.next := l;
   l := p;
   //p^.prev := p1;
end;
 
procedure Drop(var l: tList);//удалить элемент
var
   p{, p1}: tPtr;
begin
   p := l;
   l := l^.next;
  { p1 := l;
   l := l^.prev;}
   Dispose(p);
end;
 
procedure Clear(var l: tList);//очистка
begin
   while NotEmpty(l) do
      Drop(l);
end;
 
procedure WriteList(var l: tList);
var
   p: tPtr;
begin
   p := l;
   while p <> nil do 
   begin
      write(p^.data, ' ');
      p := p^.next;
   end;
end;
 
procedure Fill(var l: tList);//заполнить список
var
   x: tData;
begin
   Clear(l);
   writeln( 'Вводите элементы(целые числа) по одному' );
   writeln( 'Конец ввода - 0' );
   repeat
      write( '? ' ); readln(x);
      if x <> 0 then
         Put(l, x);
   until x = 0;
end;
 
function Counter(l: tList): integer;//счетчик числа элементов
var
   p: tPtr;
   n: integer;
begin
   n := 0;
   p := l;
   while p <> nil do 
   begin
      n := n + 1;
      p := p^.next;
   end;
   Counter := n;
end;
 
procedure CountList(l: tList);//подсчитать число элементов
begin
   writeln( 'Число элементов в списке равно ', Counter(l) );
end;
 
procedure Add1(var l: tList);//включение эл. после указанного
var
   i, k: integer;
   q, p: tPtr;
   D: tData;
begin
   writeln( 'Номер элемента: ' ); readln(k);
   if k <= Counter(l) then begin
      new(q);
      writeln( 'Задайте значение элемента: ' ); readln(q^.data);
      p := l;
      for i := 1 to k - 1 do 
         p := p^.next;
      q^.next := p^.next;
      p^.next := q;
      WriteList(l);
   end
   else 
      writeln('Элемента с таким номером не существует');
end;
 
procedure Add2(var l: tList);//включение эл. перед указанным
var
   q, p: tPtr;
   i, k: integer;
begin
   writeln( 'Номер элемента: ' ); readln(k);
   if k <= Counter(l) then begin
      new(q);
      writeln( 'Задайте значение элемента: ' ); readln(q^.data);
      if k = 1 then begin
         q^.next := l;
         l := q;
         WriteList(l)
      end
      else begin
         p := l;
         for i := 1 to k - 2 do
            p := p^.next;
         q^.next := p^.next;
         p^.next := q;
         WriteList(l);
      end
   end
   else 
      writeln('Элемента с таким номером не существует');
end;
 
procedure Exception(var l: tList);//исключение указанного эл., доделать
var
   p, q: tPtr;
   k, i: integer;
begin
   writeln( 'Номер удаляемого элемента: ' ); readln(k);
    if NotEmpty(l)  then begin
       if k <= Counter(l) then begin
          new (q);
          p := l;
          for i := 1 to k do
             Drop(p);
          WriteList(l);
        end
        else
           writeln('Элемента с таким номером не существует');
        end
     else
        Error( 'Список пуст' );
end;
 
procedure ExcFoll(var l: tList);// исключение эл., следующего за данным
var
   p, q: tPtr;
   k, i: integer;
begin
   writeln( 'Номер удаляемого элемента: ' ); readln(k);
      if NotEmpty(l)  then begin
       if k <= Counter(l) then begin
          new (q);
          p := l;
          for i := 1 to k - 1 do
             Drop(p);
          WriteList(p);
        end
        else
           writeln('Элемента с таким номером не существует');
        end
     else
        Error( 'Список пуст' );
end;
 
procedure ShowMenu;//показать меню
begin
   writeln( 'Операции с двунаправленным списком ' );
   writeln( '-------------------------------' );
   writeln( '1 - Заполнение         2 - Очистка ' );
   writeln( '3 - Вывод на экран   4 - Число элементов ' );
   writeln( '5 - Включение элемента после указанного' );
   writeln( '6 - Включение элемента перед указанным ' );
   writeln( '7 - Исключение указанного элемента ' );
   writeln( '8 - Исключение элемента, следующего за указанным ' );
   writeln( '0 - Выход ' );
   writeln( 'Выберите нужный пункт ' );
end;
 
 
begin
   Init(l);
   ShowMenu;
   repeat
      writeln;
      write( '>' );
      readln(key);
      case key of
         1: Fill(l); //заполнить список
         2: Clear(l); //очистить
         3: WriteList(l); //напечатать
         4: CountList(l); //подсчитать число элементов
         5: Add1(l); //включение эл. после указанного
         6: Add2(l); //включение эл. перед указанным
         7: Exception(l); //исключение указанного эл.
         8: ExcFoll(l); //исключение эл., следующего за указанным
         0:             {Пусто};
      else
         ShowMenu;
      end;
   until key = 0;
end.