Колдунчик.ру

program prog_arrays;
const MAX_ARR_MEM=100;
type int_array = array [1..MAX_ARR_MEM] of integer;
type int_arrayd = array [1..MAX_ARR_MEM*2] of integer;
var
   a1,a2,a3: int_array;
   a4: int_arrayd;
   a1l,a2l,a3l,a4l: integer;

procedure input_array(var a:int_array;var al: integer);
var
   tmp:integer;
begin
   al := 0;
   writeln('Input array (-1 ends input): ');
   while true do begin
      readln(tmp);
      if tmp <> -1 then begin
         al := al + 1;
         a[al] := tmp
      end else begin
         break
      end;
      if al >= MAX_ARR_MEM then
         break
   end
end;

procedure print_array(a:array of integer;al:integer);
begin
   for al := 0 to al-1 do
      write(a[al],' ');
   writeln();
end;

procedure qsort(var a:array of integer;l:integer;r:integer);
var x,y,i,j: integer;
begin
   i := l;
   j := r;
   x := a[(l+r) DIV 2];
   repeat
      while a[i] < x do i:=i+1;
      while x < a[j] do j:=j-1;
      if i<=j then begin
         y := a[i]; a[i] := a[j]; a[j] := y;
         i := i+1; j := j-1
      end
   until i > j;
   if l < j then qsort(a,l,j);
   if i < r then qsort(a,i,r);
end;

procedure intersect_ordered(
   a1   :int_array;
   a1l   :integer;
   a2   :int_array;
   a2l   :integer;
   var a3   :int_array;
   var a3l   :integer
);
var
   i,j   :integer;
begin
   i := 1;
   j := 1;
   a3l := 0;
   while (i<=a1l) and (j<=a2l) do begin
      if (a1[i] < a2[j]) then
         i := i+1
      else if (a1[i] > a2[j]) then
         j := j+1
      else begin
         a3l := a3l + 1;
         a3[a3l] := a1[i];
         while (a1[i] = a3[a3l]) and (a1[i] = a2[j]) and (i<=a1l) and (j<=a2l) do begin
            i := i+1;
            j := j+1;
         end
      end;
   end
end;

procedure substract_ordered(
   a1   :int_array;
   a1l   :integer;
   a2   :int_array;
   a2l   :integer;
   var a3   :int_array;
   var a3l   :integer
);
var
   i,j   :integer;
begin
   i := 1;
   j := 1;
   a3l := 0;
   while (i<=a1l) and (j<=a2l) do begin
      if (a1[i] < a2[j]) then begin
         a3l := a3l + 1;
         a3[a3l] := a1[i];
         i := i+1
      end else if a1[i] > a2[j] then
         j := j+1
      else begin
         while (a1[i] = a2[j]) and (i<=a1l) and (j<=a2l) do begin
            i := i+1;
            j := j+1;
         end
      end;
   end;
   while (i<=a1l) do begin
      a3l := a3l + 1;
      a3[a3l] := a1[i];
      i := i+1
   end
end;

procedure merge_ordered(
   a1   :int_array;
   a1l   :integer;
   a2   :int_array;
   a2l   :integer;
   var a3   :int_arrayd;
   var a3l   :integer
);
var
   i,j   :integer;
begin
   i := 1;
   j := 1;
   a3l := 0;
   while (i<=a1l) and (j<=a2l) do begin
      if (a1[i] < a2[j]) then begin
         a3l := a3l + 1;
         a3[a3l] := a1[i];
         i := i+1
      end else if (a1[i] > a2[j]) then begin
         a3l := a3l + 1;
         a3[a3l] := a1[i];
         j := j+1
      end else begin
         a3l := a3l + 1;
         a3[a3l] := a1[i];
         while (a3[a3l] = a1[i]) and (a1[i] = a2[j]) and (i<=a1l) and (j<=a2l) do begin
            i := i+1;
            j := j+1;
         end
      end;
   end;
   while (i<=a1l) do begin
      a3l := a3l + 1;
      a3[a3l] := a1[i];
      i := i+1
   end;
   while (j<=a2l) do begin
      a3l := a3l + 1;
      a3[a3l] := a2[j];
      j := j+1
   end
end;

{
   COMPLEXITY EVALUATION PROOF:
      qsort ~ N*log(N)+M*log(M)
      intersect_ordered ~ MIN(N,M)
      substract_ordered ~ N
      merge_ordered ~ MAX(N,M)
      total ~ N*log(N)+M*log(M)+O(MAX(N,M)) ~ O(MAX(N,M)*log(MAX(N,M)))
   AGAINST TRIVIAL ALGORITHMS:
      intersect_trivial ~ N*M/2
      substract_trivial ~ N*M/2
      merge_trivial ~ N*M/2
      total ~ O(N*M/2)
}
begin
   input_array(a1,a1l);
   input_array(a2,a2l);
   qsort(a1,0,a1l-1);
   qsort(a2,0,a2l-1);
   writeln('First array: ');
   print_array(a1,a1l);
   writeln('Second array: ');
   print_array(a2,a2l);
   writeln('Array intersection: ');
   intersect_ordered(a1,a1l,a2,a2l,a3,a3l);
   print_array(a3,a3l);
   writeln('Array substraction: ');
   substract_ordered(a1,a1l,a2,a2l,a3,a3l);
   print_array(a3,a3l);
   writeln('Array merge: ');
   merge_ordered(a1,a1l,a2,a2l,a4,a4l);
   print_array(a4,a4l);
end.

  program l;
   uses wincrt;
  var a,b:array[1..1000] of integer;
  n1,n2,j,i:integer;
function numberin(x,size:integer;y:array[1..1000] of integer):boolean;
begin
i:=1;
while (i<=size)and(y[i]<>x) do inc(i);
numberin:=(i<=size);
end;
begin
writeln('Количество чисел 1-го массива');
read(n1);
writeln('Числа:');
for j:=1 to n1 do
read(a[j]);
writeln('Количество чисел 2-го массива');
read(n2);
writeln('Числа:');
for j:=1 to n2 do
read(b[j]);
{Задание a) }
Write('В обоих массивах:');
for j:=1 to n1 do
if numberin(a[j],n2,b) then write(a[j],', ');
writeln;
{Задание б) }
writeln('В первом есть, во втором нет:');
for j:=1 to n1 do
if not numberin(a[j],n2,b) then write(a[j],', ');
writeln;
{Задание в) }
writeln('Есть хотя бы в одном массиве');
for j:=1 to n1 do write(a[j],', ');
for j:=1 to n2 do
if not numberin(b[j],n1,a) then write(b[j],', ');
writeln;
readln;
end.

...
function numberin(x,size:integer;y:array[1..1000] of integer):boolean;
begin
i:=1;
while (i<=size)and(y[i]<>x) do inc(i);
numberin:=(i<=size);
end;
...

for i := 1 to 10000 do begin
  writeln(i);
  numberin(1,10,[1,2,3,4,5,6,7,8,9,10]); 
end;

function numberin(x,size:integer;y:array of integer):boolean;
var
  i:integer;
begin
  i:=1;
  while (i<=size) and (y[i]<>x) do i := i+1;
  numberin := (i<=size);
end;