Pascal. Обмен числами между динамическими списками

[andrew_ryaba]

Здравствуйте! Помогите пожалуйста. Есть такая задача, которую надо сделать отдельными процедурами для массивов и для линейных динамических списков:
Два массива обмениваются числами так, чтобы в одном оказались только четные значения, а в другом - нечетные значения. Затем привести количество чисел к одинаковой длине путем удаления начальных значений. Исходные данные считываются из текстового файла.
Я написал процедуру для массива, но не могу понять, как реализовать примерно этот же алгоритм, применяя списки?

procedure MASSIV;
type aa=array [1..n] of integer;
var  A,B: aa;
  i: integer;
  ka,kb: integer;
procedure SOZDANIEMASSIVA(var C:aa; var kolzap:integer);
  begin
    clrscr;
    i := 0;
    Reset(f1);
    while not seekeof(f1) do
    begin
      inc(i);
      read(f1, C[i]);
    end;
    kolzap := i;
  end;

  procedure VIVODMASSIVA(txt: string; C:aa; k:integer);
  var
    i: integer;
  begin
    writeln(txt);
    for i := 1 to k do
      write(C[i]:3);
    writeln;
  end;
  
  procedure RABOTAMASSIVA;
  var k,i,j:integer;
  procedure urezaniemassiva;
  var j,i: integer;
  begin
  if ka<kb then
  for j:=1 to (kb-ka) do begin
  for i:=1 to n-1 do
  B[i]:=B[i+1];
  Dec(kb);
  end else 
  for j:=1 to (ka-kb) do begin
  for i:=1 to n-1 do
  A[i]:=A[i+1];
  Dec(ka);
  end;
  end;
  
  begin
  j:=kb+1;
  i:=1;
  while i <= ka do begin
  if (A[i]mod 2 = 0) then begin
  B[j]:=A[i];
  Inc(j);
  for k:=i to n-1 do begin
  A[k]:=A[k+1];  
  end; 
  Dec (ka);
  end else Inc(i); 
  end;
  kb:=j-1;
  j:=ka+1;
  i:=1;
  while i <= kb do begin
  if (B[i]mod 2 = 1) then begin
  A[j]:=B[i];
  Inc(j);
  for k:=i to n-1 do begin
  B[k]:=B[k+1];  
  end;   
  Dec (kb);
  end  else Inc(i);
  end;
  ka:=j-1;
  urezaniemassiva;
  end;
  
  begin
  SOZDANIEMASSIVA(A,ka);
  SOZDANIEMASSIVA(B,kb);  
  VIVODMASSIVA('Созданный массив A',A,ka);
  VIVODMASSIVA('Созданный массив B',B,kb);
  RABOTAMASSIVA;
  VIVODMASSIVA('После обработки А',A,ka);
  VIVODMASSIVA('После обработки В',B,kb);
  Writeln('Enter-Return to Main Manu');
  Readln;
end;

[Poma][a]

uses Contnrs, Classes;

procedure InitList(var MyList : TList);
var
	p : PInteger;
	n, t, i : Integer;

begin
	MyList := TList.Create;

	ReadLn(n);
	for i := 1 to n do begin
		Read(t);
		New(p); p^ := t; 
		MyList.Add(p)
	end
end;

procedure PrintList(const MyList : TList);
var
	i : Integer;

begin
	for i := 0 to MyList.Count-1 do 
		Write(PInteger(MyList.Items[i])^, ' ');

	WriteLn
end;

procedure SwapElem(var a, b : TList);
var
	i : Integer;
begin
	for i := a.Count-1 downto 0 do begin
		if Odd(PInteger(a.Items[i])^) then begin
			b.Add(a.Items[i]);
			a.Delete(i)
		end
	end;

	for i := b.Count-1 downto 0 do begin
		if not Odd(PInteger(b.Items[i])^) then begin
			a.Add(b.Items[i]);
			b.Delete(i)
		end
	end
end;

var
	a, b : TList;

begin
	InitList(a);
	InitList(b);

	SwapElem(a, b);

	PrintList(a);
	PrintList(b);

	a.Free;
	b.Free
end.

Как-то так.. Сильно не проверял..
И да.. на счет удаления я не понял.. посему не реализовал..

[Poma][a]

Я тут подумал.. А освободит ли <TList>.Free память, на которую указывают элементы списка? В справке как-то не очень понятно написано..

[andrew_ryaba]

Спасибо! Но это не совсем то, что нужно...
мы делаем без применения Contnrs, Classes
Я решил использовать двунаправленные списки. Помогите дописать то, что я начал. Хотя бы чтобы эти два списка обменивались значениями (допустим, в списке а-нечетные значения, в-четные значения) и сразу же значение, которое передалось в другой список, удалялось из текущего

procedure DINAMO;
var
  p1, p2, p3, first1,first2: uk;    //указатели для работы со списком
  i: integer;
a,b: uk;

procedure SOZDANIEDINAMO(var a:uk);
  begin
    clrscr; //очистка экрана после предыдущих действий
    first1 := nil;first2:=nil; //запоминаем первый элемент
    while not seekeof(f1) do //выполняем до конца файла
    begin
      new(p1); //выделяем память под элемент
      read(f1, p1^.x); //считываем из текстового файла в элемент число
      P1^.Radr:=nil; P1^.Ladr:=nil;
      if first1 = nil then first1 := p1 else begin 
      p1^.Radr := p1; P1^.Ladr:=p2;
      //в первый раз укажем, что теперь первый элемент - это только что созданный элемент
      //в последующие разы указываем адрес для элемента P2 - ссылаемся на P1
      p2 := p1; //а элемент P1 переименовываем в P2, для последующего повторения действий
    end; first2:=p2;
    {p2^.adr := nil;} //завершаем список
  end;
  
  procedure VIVODDINAMO(p:uk;fir:uk;pr:boolean;txt: string);
  begin
    writeln(txt); //параметр, который будет описывать выводимый тип информации
    p1 := fir;    //указываем на первый элемент
    while p <> nil do //пробегаем до конца списка
    begin
      write(p^.x, ' ');
      if pr then P:=P^.Radr else p:=p^.Ladr;
      end;
    writeln;
  end;
  
procedure AddElem(var nach,ends:uk;znach1:integer);
begin
  if nach=nil then {не пуст ли список, если пуст, то}
  begin
    Getmem(nach,SizeOf(rec)); {создаём элемент, указатель nach уже будет иметь адрес}
    nach^.Radr:=nil; {никогда не забываем "занулять" указатели}
    nach^.Ladr:=nil; {аналогично}
    ends:=nach; {изменяем указатель конца списка}
  end
  else {если список не пуст}
  begin
    GetMem(ends^.Radr,SizeOf(rec)); {создаём новый элемент}
    ends^.Radr^.Ladr:=ends; {связь нового элемента с последним элементом списка}
    ends:=ends^.Radr;{конец списка изменился и мы указатель "переставляем"}
    ends^.Radr:=nil; {не забываем "занулять" указатели}
  end;
  ends^.x:=znach1; {заносим данные}
end;

Procedure DelElem(var spis1,spis2:uk;tmp:uk);
var
  tmpi:uk;
begin
  if (spis1=nil) or (tmp=nil) then
    exit;
  if tmp=spis1 then {если удаляемый элемент первый в списке, то}
  begin
    spis1:=tmp^.Radr; {указатель на первый элемент переставляем на следующий элемент списка}
    if spis1<>nil then {если список оказался не из одного элемента, то}
      spis1^.Ladr:=nil {"зануляем" указатель}
    else {в случае, если элемент был один, то}
      spis2:=nil; {"зануляем" указатель конца списка, а указатель начала уже "занулён"}
    FreeMem(tmp,SizeOf(rec));
  end
  else
    if tmp=spis2 then {если удаляемый элемент оказался последним элементом списка}
    begin
      spis2:=spis2^.Ladr; {указатель конца списка переставляем на предыдущий элемент}
      if spis2<>nil then {если предыдущий элемент существует,то}
        spis2^.Radr:=nil {"зануляем" указатель}
      else {в случае, если элемент был один в списке, то}
        spis1:=nil; {"зануляем" указатель на начало списка}
      FreeMem(tmp,SizeOf(rec));
    end
    else {если же удаляется список не из начали и не из конца, то}
    begin
      tmpi:=spis1;
      while tmpi^.Radr<>tmp do {ставим указатель tmpi на элемент перед удаляемым}
        tmpi:=tmpi^.Radr;
      tmpi^.Radr:=tmp^.Radr; {меняем связи}
      if tmp^.Radr<>nil then
        tmp^.Radr^.Ladr:=tmpi; {у элемента до удаляемого и после него}
      FreeMem(tmp,sizeof(rec));
    end;
end;

[GetMax]

Что то вроде этого должно быть

procedure Proc(var start1, end1, start2, end2 : uk)
Begin
  While (start1 <> nil) do
  Begin
     if odd(start1.value) then 
     Begin
        AddElem(start2,end2;start1.value);
        DelElem(start1,end1; start1.value);
     end;
     start1 = start1.next //к следующему элементу
  End;
End;

По аналогии со вторым списком. Сложно что то говорить не зная как у вас определены типы данных.

[andrew_ryaba]

типы так:
type
Uk = ^rec;
rec = record
x: integer;
Radr,Ladr: Uk;
end;

type f1: Text;

[GetMax]

Не вижу какие преимущества тут у двунаправленного списка. ИМХО лучше переписать код для однонаправленного списка. С ним легче будет работать.

[andrew_ryaba]

Я подумал, что с двунаправленным списком будет легче реализовать следующий пункт задания - привести количество чисел к одинаковой длине путем удаления начальных значений. Чтобы потом пойти по списку, который длиннее получится, в обратном направлении, и на определенной позиции установить nil.
Или подобное можно реализовать и с однонаправленным списком?

[andrew_ryaba]

Переписал процедуру для однонаправленного списка. Помогите, пожалуйста, найти ошибку (не работает, видимо, зацикливается)

type
  Uk = ^rec;
  rec = record
    x: integer;
    adr: Uk;
  end;
var  
  f1: Text;

procedure DINAMO;
var
  p1, p2, p3, PP_A, PP_B, first_A, first_B: uk;    {//указатели для работы со списком}
  ka, kb: integer;
  
  procedure SOZDANIEDINAMO(var first: Uk; txtname:string);
  begin
    clrscr; {//очистка экрана после предыдущих действий}
    Assign(f1, txtname);
    Reset(f1);
    first := nil; {//запоминаем первый элемент}
    while not seekeof(f1) do {//выполняем до конца файла}
    begin
      new(p1); {//выделяем память под элемент}
      read(f1, p1^.x); {//считываем из текстового файла в элемент число}
      if first = nil then first := p1 else p2^.adr := p1;
      {//в первый раз укажем, что теперь первый элемент - это только что созданный элемент}
      {//в последующие разы указываем адрес для элемента P2 - ссылаемся на P1}
      p2 := p1; {//а элемент P1 переименовываем в P2, для последующего повторения действий}
    end;
    p2^.adr := nil; {//завершаем список}
  end;
  
  procedure VIVODDINAMO(first: uk; txt: string);
  begin
    writeln(txt); {//параметр, который будет описывать выводимый тип информации}
    p1 := first;    {//указываем на первый элемент}
    while p1 <> nil do {//пробегаем до конца списка}
    begin
      write(p1^.x, ' '); {//и каждый раз выводим число из элемента}
      p1 := p1^.adr; {//и сразу же переходим к следующему элементу}
    end;
    writeln;
  end;
  
  procedure Proc(var spis1, spis2: uk; pr: boolean; var ka: integer);
  
    procedure AddElem(var spis1: Uk; znach1: integer);
    var
      tmp: Uk;
    begin
      tmp := spis1;
      while tmp^.adr <> nil do
        tmp := tmp^.adr; {ставим tmp на последний элемент списка}
      new(p3);
      p3^.x := znach1;
      p3^.adr := tmp^.adr;
      tmp^.adr := p3;
      tmp := p3^.adr;
      writeln('add');
    end;
    
    procedure DelElem(var spis1: Uk; tmp: Uk);
    var
      tmpi: Uk;
    begin
      if (spis1 = nil) or (tmp = nil) then
        exit;
      if tmp = spis1 then
      begin
        spis1 := tmp^.adr;
        dispose(tmp);
      end
      else
      begin
        tmpi := spis1;
        while tmpi^.adr <> tmp do
          tmpi := tmpi^.adr;
        tmpi^.adr := tmp^.adr;
        dispose(tmp);
      end;
      writeln('del');
    end;
  
  begin
  writeln('start proc');
    p1 := spis1;
    while (p1^.adr <> nil) do
    begin
      if (p1^.x mod 2 = 0) = pr then 
      begin
        AddElem(spis2, p1^.x);
        DelElem(spis1, p1);
      end;
      p1 := p1^.adr;{//к следующему элементу}
    end;
    writeln('obrabotka zavershena');
    ka := 0;
    p1 := spis1;
    while p1^.adr <> nil do 
    begin
      p1 := p1^.adr;
      ka := ka + 1;
    end;
    writeln('kolvo raschitano');
  end;
  
  procedure urezaniespiska(var first_A: Uk; ka, kb: integer);
  var
    j: integer;
  begin
  writeln('start urezanie spiska');
    p1 := first_A;
    for j := 1 to (ka - kb) do 
    begin
      first_A := p1^.adr;
      dispose(p1);
      p1 := first_A;
    end;
    writeln('stop urezanie spiska');
  end;

begin
  SOZDANIEDINAMO(first_A, 'curs1.txt');
  SOZDANIEDINAMO(first_B, 'curs2.txt');
  VIVODDINAMO(first_A, 'spisok A');
  VIVODDINAMO(first_B, 'spisok B');
  proc(first_A, first_B, true, ka);
  proc(first_B, first_A, false, kb);
  if ka > kb then urezaniespiska(first_A, ka, kb) else urezaniespiska(first_B,kb,ka);
  VIVODDINAMO(first_A, 'spisok A');
  VIVODDINAMO(first_B, 'spisok B');
end;

[Serge_Bliznykov]

угу. была парочка ГРУБЫХ ошибок. (и не грубых - тоже!)
А ещё было видно, что куски кода написаны разными людьми (взяты из разных источников)
а ещё - глобальные переменные там, где они НЕ НУЖНЫ!

поправил чуток. прогнал в отладчике. вроде бы работает.
проверяйте:

uses CRT;

type
  Uk = ^rec;
  rec = record
    x: integer;
    adr: Uk;
  end;
var
  f1: Text;

procedure DINAMO;

  procedure SOZDANIEDINAMO(var first: Uk; txtname:string);
  var p1,p2 : uk;
  begin
    clrscr; {//очистка экрана после предыдущих действий}
    Assign(f1, txtname);
    Reset(f1);
    first := nil; {//запоминаем первый элемент}
    while not seekeof(f1) do {//выполняем до конца файла}
    begin
      new(p1); {//выделяем память под элемент}
      read(f1, p1^.x); {//считываем из текстового файла в элемент число}
      if first = nil then first := p1 else p2^.adr := p1;
      {//в первый раз укажем, что теперь первый элемент - это только что созданный элемент}
      {//в последующие разы указываем адрес для элемента P2 - ссылаемся на P1}
      p2 := p1; {//а элемент P1 переименовываем в P2, для последующего повторения действий}
    end;
    p2^.adr := nil; {//завершаем список}
  end;

  procedure VIVODDINAMO(first: uk; txt: string);
  var p1 : uk;
  begin
    writeln(txt); {//параметр, который будет описывать выводимый тип информации}
    p1 := first;    {//указываем на первый элемент}
    while p1 <> nil do {//пробегаем до конца списка}
    begin
      write(p1^.x, ' '); {//и каждый раз выводим число из элемента}
      p1 := p1^.adr; {//и сразу же переходим к следующему элементу}
    end;
    writeln;
  end;

  function CountElementInList(first: uk) : integer;
  var p1 : uk;
    cnt : integer;
  begin
     cnt := 0;
     p1 := first;    {//указываем на первый элемент}
     while p1 <> nil do {//пробегаем до конца списка}
     begin
        inc(cnt); {увеличиваем счётчик на единичку}
        p1 := p1^.adr; {//и сразу же переходим к следующему элементу}
     end;  
     CountElementInList := cnt;
     writeln('kolvo raschitano: ',cnt);
  end;


  procedure Proc(var spis1, spis2: uk; pr: boolean);

    procedure AddElem(var spis1: Uk; znach1: integer);
    var
      tmp, p3: Uk;
    begin
      tmp := spis1;
      while tmp^.adr <> nil do
        tmp := tmp^.adr; {ставим tmp на последний элемент списка}
      new(p3);
      p3^.x := znach1;
      tmp^.adr := p3;
      p3^.adr := nil;
      writeln('add');
    end;

    procedure DelElem(var spis1: Uk; var tmp: Uk);
    var
      tmpi: Uk;
    begin
      if (spis1 = nil) or (tmp = nil) then
        exit;
      if tmp = spis1 then
      begin
        spis1 := tmp^.adr;
        dispose(tmp);
        tmp := spis1;
      end
      else
      begin
        tmpi := spis1;
        while tmpi^.adr <> tmp do
          tmpi := tmpi^.adr;
        tmpi^.adr := tmp^.adr;
        dispose(tmp);
        tmp := tmpi;
      end;
      writeln('del');
    end;

  var p1 : uk;
  begin
    writeln('start proc');
    p1 := spis1;
    while (p1 <> nil) do
    begin
      if (p1^.x mod 2 = 0) = pr then
      begin
        AddElem(spis2, p1^.x);
        DelElem(spis1, p1);
      end
      else
        p1 := p1^.adr;{//к следующему элементу}
    end;
    writeln('obrabotka zavershena');
  end;

  procedure urezaniespiska(var first: Uk; ka, kb: integer);
  var
    j: integer;
    p1 : Uk;
  begin
  writeln('start urezanie spiska');
    p1 := first;
    for j := 1 to (ka - kb) do
    begin
      first := p1^.adr;
      dispose(p1);
      p1 := first;
    end;
    writeln('stop urezanie spiska');
  end;

var
  first_A, first_B: uk;    {//указатели для работы со списком}
  ka, kb: integer;

begin
  SOZDANIEDINAMO(first_A, 'curs1.txt');
  SOZDANIEDINAMO(first_B, 'curs2.txt');
  VIVODDINAMO(first_A, 'spisok A');
  VIVODDINAMO(first_B, 'spisok B');
  proc(first_A, first_B, true);
  proc(first_B, first_A, false);
  ka := CountElementInList(first_A);
  kb := CountElementInList(first_B);
  WriteLn('___ after exchange _____: ');
  VIVODDINAMO(first_A, 'spisok A');
  VIVODDINAMO(first_B, 'spisok B');
  if ka<>kb then begin
     if ka > kb then urezaniespiska(first_A, ka, kb) else urezaniespiska(first_B,kb,ka);
  end;
  WriteLn('___ after trimming  _____: ');
  VIVODDINAMO(first_A, 'spisok A');
  VIVODDINAMO(first_B, 'spisok B');
end;

begin
   DINAMO;
end.

NB. сообщения writeln('add'); writeln('del'); я бы лично выкинул. Они, кроме замусорирования экрана, никакой информации не несут.. имхо..
.