Найти одинаковые числа в двух списках

type
  Tinf=integer; 
  List=^TList; 
  TList=record 
    data:TInf;  
    next,   
    prev:List;   
  end;
 
procedure Add(var stek1:List;znach1:TInf);
var
  tmp:List;
begin
  new(tmp); 
  tmp^.next:=stek1;  
  tmp^.data:=znach1; 
  stek1:=tmp; 
end;
 
 
 
procedure Print(spis1:List);
var 
  i:integer;
begin
  i := 1;
  if spis1=nil then
    writeln('Список пуст.')
  else
    begin
    while spis1<>nil do
    begin
      Write(spis1^.data,'[',i,']', '<-> ');
      i+=1;
      spis1:=spis1^.next;
    end;
    end;
end;
 
 
Procedure deletelist(spis1:List);
var
  tmp:List;
begin
  while spis1<>nil do
  begin
    tmp:=spis1;
    spis1:=spis1^.next;
    dispose(tmp);
  end;
end;
 
 
Function find(spis1:List;znach1:TInf):List;
begin
  if spis1<>nil then
    while (Spis1<>nil) and (znach1<>spis1^.data) do
      spis1:=spis1^.next;
  find:=spis1;
end;
 
 
Procedure Delete(var spis1,spis2:List;tmp:List);
var
  tmpi:List;
begin
  if (spis1=nil) or (tmp=nil) then
  else
    begin
    if tmp=spis1 then 
    begin
      spis1:=tmp^.next; 
      if spis1<>nil then 
        spis1^.prev:=nil 
      else 
        spis2:=nil; 
      dispose(tmp);
    end
    else
      if tmp=spis2 then 
      begin
        spis2:=spis2^.prev; 
        if spis2<>nil then 
          spis2^.next:=nil 
        else 
          spis1:=nil; 
        dispose(tmp);
      end
      else 
      begin
        tmpi:=spis1;
        while tmpi^.next<>tmp do 
          tmpi:=tmpi^.next;
        tmpi^.next:=tmp^.next; 
        if tmp^.next<>nil then
          tmp^.next^.prev:=tmpi; 
        dispose(tmp);
      end;
      end;
end;
 
Procedure Deletepos(var spis1,spis2:List;posi:integer);
var
  i:integer;
  tmp:List;
begin
  if posi<1 then
    writeln('неверный ввод');
  if spis1=nil then
  begin
    Write('Список пуст');
  end
  else 
    begin
      i:=1;
      tmp:=spis1;
      while (tmp<>nil) and (i<>posi) do
      begin
        tmp:=tmp^.next;
        inc(i)
      end;
      if tmp=nil then
      begin
        Writeln('Элемента с порядковым номером ' ,posi, ' нет в списке.');
        writeln('В списке всего ' ,i-1, ' элементов.');
      end;
      Delete(spis1,spis2,tmp);
      Writeln('Элемент удалён.');
    end;
end;
 
var
  SpisNach, 
  SpisEnd,   
  tmpl:List;
  znach,q:integer;
begin
  SpisNach:=nil;
  SpisEnd:=nil;
  repeat
    Writeln('1) Добавить элемент.');
    Writeln('2) Вывод списка.');
    Writeln('3) Удаление элемента.');
    Writeln('4) Поиск элементов по значению.');
    Writeln('5) Выход.');
    writeln;
    readln(q);
    case q of
      1:begin
            write('Введите значение добавляемого элемента: ');
            readln(znach);
            Add(SpisNach,znach);
          end;
      2:begin
            Print(SpisNach);
            writeln;
          end;
      3:begin
            Write('Введите номер удаляемого элемента: ');
            readln(znach);
            znach := znach - 1;
            Deletepos(SpisNach,SpisEnd,znach);
          end;
      4:begin
            write('Введите значение искомого элемента: ');
            readln(znach);
            tmpl:=find(SpisNach,znach);
            if tmpl=nil then
              write('Искомый элемент отсутствует в списке.')
            else
            begin
              write('Элемент ');
              Write(tmpl^.data);
              Write(' найден');
              writeln;
            end;
          end;
    end;
  until q=5;
  deletelist(SpisNach);
end.

type
  tList = ^pList;
  pList = record
    v : Integer;
    x : tList;
  end;
 
procedure Add(var l : tList; v : integer);
var x : tList;
begin
  if l = nil then
    begin
      new(l); l^.v := v; l^.x := nil;
    end
  else if l^.v <> v then
    begin
      x := l;
      while (x^.x <> nil) and (x^.x^.v <> v) do x := x^.x;
      if x^.x = nil then Add(x^.x, v);
    end;
end;
 
function listLength(l : tList) : integer;
var x : tList; n : integer;
begin
  x := l; n := 0;
  while x <> nil do begin x := x^.x; inc(n); end;
  listLength := n;
end;
  
function genList(count, index : integer) : tList;
var l : tList; i : integer;
begin
  l := nil;
  while listLength(l) <> count do Add(l, Random(index));
  genList := l;
end;
 
procedure outList(msg : string; l : tList);
begin
  Write(msg);
  if l = nil then Write(' список пуст') else while l <> nil do begin Write(#32, l^.v); l := l^.x; end;
  WriteLn;
end;
 
function contains(l : tList; v : integer) : boolean;
begin
  contains := true;
  while l <> nil do if l^.v = v then exit else l := l^.x;
  contains := false;
end;
 
function findEquals(l1, l2 : tList) : tList;
var l : tList;
begin
  l := nil;
  while l1 <> nil do
    begin
      if contains(l2, l1^.v) then Add(l, l1^.v);
      l1 := l1^.x;
    end;
  findEquals := l;
end;
  
var l1, l2, lo : tList;
begin
  l1 := genList(10, 20); outList('1 список:', l1);
  l2 := genList(10, 20); outList('2 список:', l2);
  lo := findEquals(l1, l2);
  outList('одинаковые числа:', lo);
end.