Исключение указанного элемента в двунаправленном списке

program list;
 
type
   tData = integer;
   tPtr = ^tNode;
   tNode = record
      next: tPtr;
      data: tData;
      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 Drop(var l: tList);//удалить элемент
var
   p: tPtr;
begin
   repeat
      if l <> nil then begin
         p := l;
         l := l^.next;
         Dispose(p);
      end;   
   until l = nil; 
   key := 0;
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;
   q: tPtr;
begin
   key := 0;
   Clear(l);
   writeln( 'Вводите элементы(целые числа) по одному' );
   writeln( 'Конец ввода - 0' );
   repeat
      write('?');
      readln(x);
      if x <> 0 then begin
         New(q);
         q^.data := x;
         q^.next := l;
         if l <> nil then
            l^.prev := q;
         l := q;
         q^.prev := nil;
      end;
      if x <> 0 then 
         key := key + 1;
   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, r: tPtr;
begin
   writeln( 'Номер элемента: ' ); readln(k);
   if k <= Counter(l) then begin
      new(q);
      writeln( 'Задайте значение элемента: ' ); readln(q^.data);
      p := l;
      for i := 1 to k do 
            p := p^.next;
      if p <> nil then begin 
         r := p^.prev;
         q^.next := p;
         q^.prev := r;
         r^.next := q;
         p^.prev := q;
      end
      else begin
         p := l;
         for i := 1 to k-1 do 
               p := p^.next;
         q^.next := nil;
         p^.next := q;
         q^.prev := p;
      end;
      WriteList(l);
      
   end
   else 
      writeln('Элемента с таким номером не существует');
end;
 
procedure Add2(var l: tList);//включение эл. перед указанным
var
   q, p, r: 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^.prev := nil;
         q^.next := l;
         l^.prev := q;
         l := q;
         WriteList(l)
      end
      else begin
         p := l;
         for i := 1 to k - 1 do
            p := p^.next;
         r := p^.prev;
         q^.next := p;
         q^.prev := r;
         r^.next := q;
         p^.prev := q;
         WriteList(l);
      end
   end
   else 
      writeln('Элемента с таким номером не существует');
end;
 
[B]procedure Exception(var l: tList);//исключение указанного эл., доделать, не удаляет первый элемент
var
   i, k: integer;
   p, q: tPtr;
begin
   Write('Введите номер удаляемого элемента: ');
   readln(k);
   if (k <= Counter(l)) and (l <> nil) then begin
    
    p := l;
      for i := 1 to k - 2 do
         if p <> nil then
            p := p^.next;     
      if p <> nil then begin
         q := p^.next;
         if q <> nil then begin
            if k <> 0 then begin
                if k=1 then begin
                   p^.prev := nil;
                   q^.next:= p;
                   Dispose(q);
                end
                else begin
               p^.next := q^.next;
               q^.prev := p;
               Dispose(q);
              end
            end
            else begin
               p^.next := nil;
               q^.prev := nil;
               Dispose(q);
            end;
         end;
      end;
   end   
   else if k > Counter(l) then begin
      writeln;
      writeln('Удаляемого элемента в списке нет');
      writeln;
   end
   else begin
      Writeln;
      writeln('Список ещё не заполнен');
      writeln;
   end;   
end;[/B]
 
procedure ExcFoll(var l: tList);// исключение эл., следующего за данным
var
   i, k: integer;
   p, q: tPtr;
begin
   Write('Удалить после элемента с номером: ');
   readln(k);
   if (k < Counter(l)) and (l <> nil) then begin
      p := l;
      for i := 2 to k do
         if p <> nil then
            p := p^.next;     
      if p <> nil then begin
         q := p^.next;
         if q <> nil then begin
            if k <> 0 then begin
               p^.next := q^.next;
               q^.prev := p;
               Dispose(q);
            end
            else begin
               p^.next := nil;
               q^.prev := nil;
               Dispose(q);
            end;
         end;
      end;
      //key := key - 1;
   end   
   else if k >= Counter(l) then begin
      writeln;
      writeln('Удаляемого элемента в списке нет');
      writeln;
   end
   else begin
      Writeln;
      writeln('Список ещё не заполнен');
      writeln;
   end;   
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.