Задача на двумерный список Опции

[habi]

Задача. используя динамические списки, найти в массиве последнию группу положительных элементов, и удалить её.
Проблема: не могу установить указатели конца(вроде установил) и начала последней группы положительных элементов.
Если есть другие предложения по алгоритму, просьба высказать.
Вот набросал за сегодня :

program labа;
uses
  crt;
type
  ukaz=^mas;
  mas=record
        chisl:integer;
        next:ukaz;
        pred:ukaz;
      end;
Var
  first, tek, tmp, last,listkon,listnach: ukaz;
  i,j,n,nach,konec,temp:integer;
{----------------------------------------------------------------------------}
procedure CreateSpisok(n:integer);
Begin
  write('Vvedite koli4estvo 4isel massiva->');
  readln(n);
  new(first);
  first^.pred:=nil;
  first^.chisl:=random(200)-50;
  tek:=first;
  for i:=1 to n do
  begin
    new(tek^.next);
    tek^.next^.chisl:=random(200)-50;
    tek^.next^.pred:=tek;
    write(tek^.chisl:5);
    tek:=tek^.next;
  end;
  tek^.next:=nil;
  writeln;
end;
{----------------------------------------------------------------------------}
Function SearchLastPolGroup: ukaz;
var
  Pol:ukaz;
begin
  Pol:=first;
  while (pol^.chisl<=0)  and (pol^.next<>nil) do
    pol:=pol^.next;
  if pol^.chisl>0 then
    SearchLastPolGroup:=pol
  else
    SearchLastPolGroup:=nil;
end;
{----------------------------------------------------------------------------}
Procedure DisposeRec;
var
  temp:ukaz;
begin
  tek:=first;
  repeat
    temp:=tek^.next;
    tek:=temp;
  until  tek=nil;

end;
{----------------------------------------------------------------------------}
BEGIN
  randomize;
  clrscr;
  writeln;
  writeln('Programma formiruet dinamy spisok, i perenosit ponextniy gruppu pol elementov');
  writeln('v nachalo spiske dinam, i zamenaet ego nylami, gruppa eto elementi > 2 shtuk');  writeln;
  textcolor(red);
  writeln('Svobodnaja pamjat do nachala ',memavail,' kb');
  writeln;
  CreateSpisok(n);
  tek:=first;
  i:=1;
  while tek^.next<>nil do
  begin
    if tek^.chisl>0 then
    begin
      temp:=temp+1;
      if temp>=2 then
      begin
        nach:=i-temp+1;
        konec:=i;
        listkon:=tek;
      end;
    end
    else
    temp:=0;
    tek:=tek^.next;
    i:=i+1;
  end;
{----------------------------------------------------------------------------}
  textcolor(blue);
  writeln;
  writeln('nachalo last pol. group-->',nach:3,' konecec last pol.group-->', konec:3);
  writeln('idet perestanovka i obnulenie last pol. group, najmite Enter');
  readln;
  tek:=first;

  for i:=1 to konec-1 do
    tek:=tek^.next;
    dispose(tek);
  for i:=konec downto nach do
  begin
    temp:=tek^.chisl;
    tmp:=tek;
   for j:=konec-1 downto 1 do
    begin
      tmp^.chisl:=tmp^.pred^.chisl;
      tmp:=tmp^.pred;
    end;
    first^.chisl:=temp;
  end;
{----------------------------------------------------------------------------}

   listnach:=first;tek:=listnach;
   repeat
   tmp:=tek^.next;
   dispose(tek);
   tek:=tmp;
   until tek=listkon;
   {----------}
  writeln;
  textcolor(lightblue);
  tek:=first;
  if SearchLastPolGroup<>nil then
    while tek^.next<>nil do
    begin
      write(tek^.chisl:5);
      tek:=tek^.next;
    end
  else
  writeln('pol. grup elementov net');
  writeln;
  writeln;
  writeln('Svobodnaja pamjat v processe ',memavail,' kb');
  readln;
  DisposeRec;
  textcolor(green);
  writeln;
  writeln('Svobodnaja pamjat posle o4ustku ',memavail,' kb');
  readln;
end.

[habi]

Нашёлся баг

Если список состоит из элементов типа этих
-+++--+-+++-+
то программа просто зависала.



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

program laba;
uses
  crt;
type
  ukaz=^mas;
  mas=record
		chisl:integer;
		next:ukaz;
		pred:ukaz;
	  end;
Var
  first, listkon , tek, tmp, listnach, last: ukaz;
  i,j,n,nach,konec,temp:integer;
{----------------------------------------------------------------------------}
procedure CreateSpisok(n:integer);
Begin
  write('Vvedite koli4estvo 4isel massiva, bolse 4->');
  readln(n);
  new(first);
  first^.pred:=nil;
  first^.chisl:=random(200)-100;
  tek:=first;
  for i:=1 to n do
  begin
	new(tek^.next);
	tek^.next^.chisl:=random(200)-100;
	tek^.next^.pred:=tek;
	write(tek^.chisl:5);
	tek:=tek^.next;
  end;
  tek^.next:=nil;
 last:=tek^.pred;
end;
{----------------------------------------------------------------------------}
Function SearchPol: ukaz;
var
  Pol:ukaz;
begin
  Pol:=first;
  while (pol^.chisl<=0)  and (pol^.next<>nil) do
	pol:=pol^.next;
  if pol^.chisl>0 then
	searchPol:=pol
  else
	searchPol:=nil;
end;
{----------------------------------------------------------------------------}
Procedure DisposeRec;
var
  temp:ukaz;
begin
  tek:=first;
  repeat
	temp:=tek^.next;
	dispose(tek);
	tek:=temp;
  until  tek=nil;

end;
{----------------------------------------------------------------------------}
BEGIN
randomize;
  clrscr;
  writeln;
  writeln('Programma formiruet dinamy spisok, i ydaliet posledniy gruppu pol elementov');
  writeln;
  textcolor(red);
  writeln('Svobodnaja pamjat do nachala ',memavail,' kb');
  writeln;
  CreateSpisok(n);

  tek:=last;
  tek^.next:=nil;
  while tek^.pred<>nil do
  begin
	if tek^.chisl>0 then
	begin
	  temp:=temp+1;
	  if temp=1 then
	  begin
	  listkon:=tek;
	  if listkon=last then listkon:=last;
	  end
	  else
	  begin
	  if temp>=2 then
		 begin
		   repeat
		   tek:=tek^.pred;
		   until (tek^.pred^.chisl<0);
		   listnach:=tek;
		   break;
		  end;
		 end;
	end
	else
	temp:=0;
	tek:=tek^.pred;

end;
 {----------------------------------------------------------------------------}
  writeln; writeln;
  writeln('last', last^.chisl);
  writeln('first',first^.chisl );
  writeln('listnach',listnach^.chisl);
  writeln('listkon',listkon^.chisl);
  textcolor(blue);
  writeln;
  writeln('idet udalenie last pol. group, najmite Enter');
  readln;
	   if listkon=last then	 {esli posled v konce }
		while listkon^.chisl>0 do
		begin
		listkon:=listkon^.pred;
		dispose(listkon^.next);
		listkon^.next:=nil;
		last:=listkon;
		end;
	  if (listnach<>first) and (listkon<>last) then
	  while listnach^.chisl>0  do				  {esli posled v seredine}
		 begin
		 tmp:=listnach;
		 listnach^.pred^.next:=listnach^.next;
		 listnach^.next^.pred:=listnach^.pred;
		 listnach:=listnach^.next;
		 dispose(tmp);
		 end;

	  if listnach=first then	 {esli posled v nach	}
		 while listnach^.chisl>0 do
		 begin
		 listnach:=listnach^.next;
		 dispose(listnach^.pred);
		 listnach^.pred:=nil
		 end;

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

   writeln; writeln;
  writeln('last', last^.chisl);
  writeln('first',first^.chisl );
  writeln('listnach',listnach^.chisl);
  writeln('listkon',listkon^.chisl);

 writeln;
  textcolor(lightblue);
  tek:=first;
  if SearchPol<>nil then
	while (tek^.next<>nil)  do
	begin
	  write(tek^.chisl:5);
	  tek:=tek^.next;
	end
  else
  writeln('pol. grup elementov net');
  write(last^.chisl:5);
  writeln; writeln;
  writeln('Svobodnaja pamjat v processe ',memavail,' kb');
  readln;
  DisposeRec;
  textcolor(green);
  writeln;
  writeln('Svobodnaja pamjat posle o4ustku ',memavail,' kb');
  readln;
end.

Проблема: теперь если список вида -++-+-++-, то конец последовательности находит правильно, а начало, нет. Оно выделено жирным.


2volvo: а как это без указателей начала и конца последовательности?

Сообщение отредактировано: habi - 18.05.2008 12:25