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

[Fores]

Доброго времени суток, уважаемые форумчане! Прошу консультации по след.задаче:

Все нечетные числа записать в начало данных, четные – в конец данных. Повторяющиеся числа не писать. Уравнять количество четных и нечетных удалением последних значений в своей последовательности. Решить, используя дин.списки

Вся проблема в итоговом списке, точнее в его выводе. При компиляции в 80% случаев выдается след. ошибка:
Ошибка времени выполнения: Ссылка на объект не указывает на экземпляр объекта., в остальных случаях программа компилируется корректно. В чем причина?
Прилагаю следующий код:

const n=20;
type din=^rec;
rec=record
x:integer;
adr: din;
end;
var p,first,r: din;
mn:set of integer;
f1:file of integer;
i,b,k,buf,ch,nch:integer;
priz:boolean;
begin
assign(f1,'f1.pas');
rewrite(f1);
for i:=1 to n do begin
b:=random(30)+10;
write(f1,b);
end;
reset(f1);
while not eof(f1) do begin
new(p);
read(f1,p^.x);
write(p^.x:4);
first:=p;
for i:=2 to n do begin
new(p^.adr);
p:=p^.adr;
read(f1,p^.x);
write(p^.x:4);
end;
end;
writeln;
k:=n;
repeat
dec(k);
priz:=true;
p:=first;
for i:=1 to k do 
while p^.adr<>nil do begin
if (p^.x mod 2 = 0) and (p^.adr^.x mod 2 = 1) then begin
buf:=p^.x;
p^.x:=p^.adr^.x;
p^.adr^.x:=buf;
priz:=false;
end;
p:=p^.adr;
end;
until priz;
p:=first;
r:=p;
while p<>nil do begin
if not(p^.x in mn) then begin
write(p^.x:4);
mn:=mn+[p^.x];
if (p^.x mod 2 = 0) then inc(ch) else inc(nch);
p:=p^.adr;
end
else begin
r^.adr:=p^.adr;
dispose(p);
p:=r^.adr;
end;
end;
writeln(' Нечетных ', nch, ' Четных ', ch);
writeln;
if ch>nch then begin
p:=first;
r:=p;
for i:=1 to 2*nch do begin
write(p^.x:4);
p:=p^.adr;
end;
end
else begin
p:=first;
r:=p;
for i:=1 to ch do begin
write(p^.x:4);{Здесь выскакивает ошибка}
p:=p^.adr;
end;
for i:=ch+1 to nch do begin
r^.adr:=p^.adr;
dispose(p);
p:=r^.adr;
end;
for i:=nch+1 to nch+ch do begin
write(p^.x:4);{Здесь выскакивает ошибка}
p:=p^.adr;
end;
end;
end.

Заранее благодарю!

[Sibedir]

Бегло.
Ошибка здесь

...
else begin
r^.adr:=p^.adr;
dispose(p);
p:=r^.adr;
end;
...

Предыдущий элемент продолжает хранить ссылку на уже удаленный из памяти дубликат.

Возможное решение: Пропускать добавление дубликатов уже на этапе формирования списка из файла.

  Reset(f1);
  while not eof(f1) do begin
    New(p);
    Read (f1, buf);
    p^.x := buf;
    Writeln (p^.x:4);
    first := p;
    mn := mn + [buf];
    for i := 2 to n do begin
      Read (f1, buf);
      if not (buf in mn) then begin
        New (p^.adr);
        p := p^.adr;
        p^.x := buf;
        Writeln (p^.x:4);
        mn := mn + [buf];
      end;
    end;
  end;

[Fores]

Сообщение от Sibedir

Бегло.
Ошибка здесь

Предыдущий элемент продолжает хранить ссылку на уже удаленный из памяти дубликат.

Ваше мнение оказалось верным, за что я Вам искренне благодарен!) Переделанная программа компилируется абсолютно верно.

Для заинтересованных выкладываю полностью рабочий код:

const n=20;
type din=^rec;
rec=record
x:integer;
adr:din;
end;
var p,first,r:din;
mn:set of integer;
f1:file of integer;
i,b,k,buf,ch,nch:integer;
priz:boolean;
begin
assign(f1,'f1.pas');
rewrite(f1);
for i:=1 to n do begin
b:=random(30)+10;
write(f1,b);
end;
Reset(f1);
  while not eof(f1) do begin
    New(p);
    Read (f1, buf);
    p^.x := buf;
    Write (p^.x:4);
    first := p;
    if (p^.x mod 2 = 0) then inc(ch) else inc(nch);
    mn := mn + [buf];
    for i := 2 to n do begin
      Read (f1, buf);
      if not (buf in mn) then begin
        New (p^.adr);
        p := p^.adr;
        p^.x := buf;
        Write (p^.x:4);
        if (p^.x mod 2 = 0) then inc(ch) else inc(nch);
        mn := mn + [buf];
      end;
    end;
end;
writeln;
k:=n;
repeat
dec(k);
priz:=true;
p:=first;
for i:=1 to k do 
while p^.adr<>nil do begin
if (p^.x mod 2 = 0) and (p^.adr^.x mod 2 = 1) then begin
buf:=p^.x;
p^.x:=p^.adr^.x;
p^.adr^.x:=buf;
priz:=false;
end;
p:=p^.adr;
end;
until priz;
writeln(' Нечетных ', nch, ' Четных ', ch);
if ch>nch then begin
p:=first;
r:=p;
for i:=1 to 2*nch do begin
write(p^.x:4);
p:=p^.adr;
end;
end
else begin
p:=first;
r:=p;
for i:=1 to ch do begin
write(p^.x:4);
p:=p^.adr;
end;
for i:=ch+1 to nch do begin
r^.adr:=p^.adr;
dispose(p);
p:=r^.adr;
end;
for i:=nch+1 to nch+ch do begin
write(p^.x:4);
p:=p^.adr;
end;
end;
end.

Проблема решена, тема закрыта)