Проблема: не могу установить указатели конца(вроде установил) и начала последней группы положительных элементов.
Если есть другие предложения по алгоритму, просьба высказать.
Вот набросал за сегодня :
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.