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

[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]

Всё-таки я не могу в этом коде выделить группу.

Всё сделал.

Сообщение отредактировано: habi - 19.05.2008 17:52