Кольцевые Двусвязные Списки Опции

[ikorstenxl]

ПОМОГИТЕ ПОЖАЛУЙСТА ДОДЕЛАТЬ ПРОГРАММУ.
Вот собственно код :

Program Kursach;
uses
  crt;
type
  Tinf=integer;
  List=^TList;
  TList=record
    data:TInf;
    next : list;
    prev : list;
  end;

{=====================================Creation of Spisok====================================}
procedure AddElem(var first:List;znach1:TInf);
var
  tmp,tmp1:List;
begin
  if first=nil then
  begin
    Getmem(first,SizeOf(TList));
    first^.next:=first;
    tmp:=first;
  end
  else
  begin
    tmp:=first;
    while tmp^.next<>first do
      tmp:=tmp^.next;
    GetMem(tmp1,SizeOf(Tlist));
    tmp1^.next:=first;
    tmp^.next:=tmp1;
    tmp:=tmp1;
  end;
  tmp^.data:=znach1;
end;

{====================================Printing of Spisok=====================================}
procedure Print(spis1:List);
var
  first:List;
begin
  if spis1=nil then
  begin
    writeln('Please add a new element');
    exit;
  end;
  first:=spis1;
  Write(spis1^.data, ' ');
  spis1:=spis1^.next;
  while spis1<>first do
  begin
    Write(spis1^.data, ' ');
    spis1:=spis1^.next;
  end;
end;
{==================================Clearing all Spisok======================================}
Procedure FreeStek(spis1:List);
var
  tmp,first:List;
begin
  if spis1=nil then
    exit;
  first:=spis1;
  tmp:=spis1;
  spis1:=spis1^.next;
  dispose(tmp);
  while spis1<>first do
  begin
    tmp:=spis1;
    spis1:=spis1^.next;
    FreeMem(tmp,SizeOf(Tlist));
  end;
end;
  {===============================================================================
===========}
Procedure DelElem(var spis1:List;tmp:List);
var
  tmpi:List;
begin
  if tmp=spis1 then
  begin
    tmpi:=tmp;
    while tmpi^.next<>spis1 do
      tmpi:=tmpi^.next;
    if tmpi=spis1 then
    begin
      spis1^.next:=nil;
      dispose(spis1);
      spis1:=nil
    end
    else
    begin
      tmpi^.next:=tmp^.next;
      spis1:=spis1^.next;
      dispose(tmp)
    end;
  end
  else
  begin
    tmpi:=spis1;
    while tmpi^.next<>tmp do
      tmpi:=tmpi^.next;
    tmpi^.next:=tmp^.next;
    dispose(tmp);
  end;
end;
 {=============================Deleting the element of Spisok===============================}
procedure DelElemZnach(var Spis1:List;znach1:TInf);
var
  tmp:List;
begin
  tmp:=spis1;

  
    if tmp^.data < 0 then                                                                    {!!!}
        if tmp^.next^.data = tmp^.prev^.data then 
  begin
    DelElem(spis1,tmp);
    exit;
  end;
  tmp:=tmp^.next;
  while tmp<>spis1 do
  begin


       if tmp^.data < 0 then                                                                  {!!!}
      if tmp^.prev^.data = tmp^.next^.data then 
    begin
      DelElem(spis1,tmp);
      exit
    end;
    tmp:=tmp^.next;
  end;
end;
{=================================Menu of Program========================================================}
var
  SpisNach,
  tmpl:List;
  znach,a,b:integer;
  ch:char;
begin
  SpisNach:=nil;
  repeat
    clrscr;
    textcolor(1);
    writeln('                     ======================================');
    writeln('                     ===                                ===');
    writeln('                     ===                                ===');
      write('                     ===');
    TextColor(4);
      Write('             WELCOME!!!');
    textcolor(1);
    writeln('         ===');
    writeln('                     ===                                ===');
    writeln('                     ===                                ===');
      write('                     ===');
    TextColor(5);
      Write('            "Circle List"');
    textcolor(1);
    writeln('       ===');
    writeln('                     ===                                ===');
    writeln('                     ===                                ===');
    writeln('                     ======================================');
    TextColor(6);
    writeln;
    writeln;
    writeln;
    writeln;
    Writeln('                           Choose the right action :');
    TextColor(7);
    writeln;
    writeln;
    Writeln('                            1) Add a new Element .');
    writeln;
    Writeln('                            2) Show the List .');
    writeln;
    Writeln('                            3) Delete the Element .');
    writeln;
    Writeln('                            4) Exit .');
    writeln;
    ch:=readkey;
    case ch of
      '1':begin
            write('Enter value of new Element  : ');
            readln(znach);
            AddElem(SpisNach,znach);
          end;
      '2':begin
            clrscr;
            Print(SpisNach);
            readkey;
          end;
      '3':begin
       DelElemZnach(SpisNach);
          end;

    end;
    until ch='4';
    freestek(spisnach);
end.

Как вы могли понять программа добавляет новый элемент в кольцевой двусвязный список, выводит на экран список,и чистит его при выходе из программы. еще есть процедура которая удаляет элементы по условию :
1) if tmp^.data < 0 then - то бишь отрицательный элемент списка,
а должно быть два условия :
1)...
2) if tmp^.prev^.data = tmp^.next^.data then - отрицательный элемент который находить между двумя одинаковыми (1 -2 1 - удалить -2).

только вот дело в том что программа ,если только с первым условием , удаляет все отрицательные элементы, а если с двумя условиями то просто не удаляет ни чего.

подскажите пожалуйста что мне исправить что бы оно делало все правильно.

[volvo]

Так вот ты для начала список правильно создай (у тебя ж заполняются только указатели next, а prev-ы остаются нетронутыми, потом, при попытке обращения к ним, будут проблемы в виде неправильной работы на старых компиляторах и вылета программы на новых).

Когда исправишь создание списка (как - можно посмотреть на этом форуме, здесь была Everveit, которая задавала несколько вопросов по двухсвязным кольцевым спискам, и получила на них ответы; можно - начертить список на бумаге, и разобраться, как меняются все указатели при добавлении нового элемента. Это - предпочтительный вариант), тогда вот такая процедура будет работать:

function RemoveItem(var first: List; p: List): List;
begin
  if first^.next = first then
  begin
    FreeMem(first, SizeOf(Tlist));
    first := nil; RemoveItem := nil; exit;
  end;

  RemoveItem := p^.next;

  p^.prev^.next := p^.next;
  p^.next^.prev := p^.prev;
  if p = first then first := p^.next;
  FreeMem(p, SizeOf(Tlist));
  p := nil;
end;


procedure Process(var first: List);
var p: List;
begin
  if first = nil then Writeln('<empty>')
  else begin
    p := first;
    repeat
      if (p^.data < 0) and (p^.next^.data = p^.prev^.data) then
      begin
        p := RemoveItem(first, p);
      end
      else p := p^.next;
    until p = first;
  end;
end;

Кстати, печать списка можно сделать гораздо красивее:

procedure Print(first: List);
var p: List;
begin
  if first = nil then Writeln('<empty>')
  else begin
    p := first;
    repeat
      write(p^.data:4); p := p^.next;
    until p = first;
  end;
  writeln;
end;

Заметь, никаких отдельных печатаний первого элемента. Он - такой же, как и все остальные, и незачем его выделять, и работать с ним по-другому