Динамические списки

[Ольчик]

Всем привет!!!! Ребята помогите пожалуйста, кто чем может!! Из-за работы времени не хватает...
В работе используются односвязные списки, информационная часть которых – целое число. Требуется создать список и выполнить задания . Для создания списка и вывода его на форму написать отдельные процедуры. Создание списка может быть выполнено по схеме:
1. «Введите количество элементов в списке» (N – количество элементов);
2. «Введите элементы списка».
В процедурах обработки списка по варианту количество элементов N не использовать.
Задания:
1. Подсчитать в списке число соседств чисел одного знака.
2. Удалить из списка каждый третий элемент.
3. Упорядочить список по возрастанию значений элементов.

[slips]

Часть задачи.. создание списка, вывод и удаление каждого третьего


uses
SysUtils;

type
sllptr = ^slltype;
slltype = record
inf : real;
next : sllptr;
end;

{********************************** *******
Вывод на печать
*********************************** ******}
Procedure LookSll(head : sllptr);
var cur : sllptr;
i:integer;
begin
i:=0;
writeln;
cur:=head;
while cur <> nil do
begin
inc(i);
writeln(cur^.inf:3:0,' : ',i,' -Элемент списка');
cur:=cur^.next;
end;
writeln;
end;

{********************************** ***
Удаление k-го элемента
*********************************** *}
Procedure DeleteSll(var head : sllptr; del : sllptr );
var prev : sllptr;
begin
if del=head then
head:=del^.next
else
begin
prev:=head;
while (prev^.next<>del) and (prev^.next<>nil) do
begin
prev:=prev^.next;
end;
prev^.next:=del^.next;
Dispose(del);
end;
end;

Var
prev,Head,P:sllptr;
i:Byte;
n:Integer;
begin
randomize;
i:=0;
prev:=nil;
Head:=nil;
repeat
{$I-}
write('Введите количество элементов списка : ');
readln(n);
{$I+}
until ioresult=0;
writeln;
while (i<n) do
begin
inc(i);
New(P); P^.inf:=Random(100)-50;
if prev <> nil then
begin
P^.next:=prev^.next; prev^.next:=P;
end
else
begin
P^.next:=head;
head:=P;
end;
end;
writeln('Список******************** *************');
LookSll(Head);
P:=Head;
i:=1;
while (P<>nil) do
begin
IF i=3 then
begin
DeleteSll(Head,P);
i:=1;
end
else
inc(i);
P:=P^.next;
end;
LookSll(Head);
dispose(P);
readln;
end.

[eoln]

Вот мой вариант полного решения

type mm = ^spisok;
spisok = record
  c: integer;
  nextrec: mm
end;
var
  current, last, first: mm;
  b: byte;
procedure add;
var
  i, N: integer;
begin
  write('N = ');
  readln(N);
  for i := 1 to N do
  begin
    write('c = '); readln(last^.c);{ last^.c := i;}
    last^.nextrec := new(mm);
    last := last^.nextrec;
  end
end;
procedure see;
begin
  current := first;
  while current <> last do begin
    writeln(current^.c);
    current := current^.nextrec;
  end;
end;
procedure del;
var
  q: integer;
  next: mm;
begin
  q := 1;
  current := first;
  while current <> last do begin
    inc(q);
    next := current^.nextrec;
    if (next <> last) and (q = 3) then
    begin
      current^.nextrec := next^.nextrec;
      if next^.nextrec = last then exit;
      q := 0
    end
    else current := current^.nextrec
  end
end;
procedure stat;
var
  q: integer;
  next: mm;
begin
  q := 0;
  current := first;
  while current <> last do begin
    next := current^.nextrec;
    if next <> last then
    if current^.c * next^.c > 0 then inc(q);
    current := current^.nextrec
  end;
  writeln('Naideno ', q, ' variantov');
end;
procedure sort;
var
  q: integer;
  current2: mm;
begin
  current := first;
  current2 := first;
  while current <> last do
  begin
    current2 := current;
    while current2 <> last do
    begin
      //обычная сортировка, при этом обмен происходит
      //информационной частью, а не указателями
      if current^.c > current2^.c then
      begin
        q := current^.c;
        current^.c := current2^.c;
        current2^.c := q
      end;
      current2 := current2^.nextrec
    end;
    current := current^.nextrec
  end;
end;   

BEGIN
  last := new(mm);
  first := last;
  repeat
    writeln;
    writeln('1-add');
    writeln('2-del');
    writeln('3-see');
    writeln('4-stat');
    writeln('5-sort');
    writeln('0-exit');
    write('vibor=');readln(b);
    case b of
      1: add;
      2: del;
      3: see;
      4: stat;
      5: sort
    end
  until b = 0;
  dispose(last);
END.

[Ольчик]

Ребята, спасибо вам большое!!! Вы можно сказать мне жизнь спасли!!!

[felixandr]

у меня была такая-же задача-
СПАСИБО ПРЕБОЛЬШОЕ!!!!