Входной файл: INPUT.TXT
Выходной файл: OUTPUT.TXT
[Задание:
Пусть задана последовательность из n (n Ј 100) целых чисел {a1, a2, ..., an} (1 Ј ai Ј 100), которая содержит m четных чисел и l - нечетных (m + l = n). Требуется получить последовательность из k пар (k = min(m, l)) {(x1, y1), (x2, y2), ..., (xk, yk)}, где x1, x2, ..., xk - взятые в порядке следования первые k четных членов последовательности {a1, a2, ..., an}, а y1, y2, ..., yk - взятые в порядке следования первые k нечетных членов последовательности {a1, a2, ..., an}.
Формат входных данных:
Входной файл INPUT.TXT состоит из двух строк. В первой строке содержится натуральное число n - длина последовательности. Во второй - идут целые числа a1, a2, ..., an, разделенные пробелами. Пример:
10
98 56 33 73 41 8 48 93 52 80
Формат выходных данных:
Выходной файл OUTPUT.TXT должен содержать последовательность {(x1, y1), (x2, y2), ..., (xk, yk)}, расположенную в одной строке файла, числа должны быть разделены пробелами. Если исходная последовательность не содержит ни одного четного или ни одного нечетного члена, т.е. k = 0, то в файл необходимо вывести цифру 0 (нуль).
Пример:
98 33 56 73 8 41 48 93

Ну что неужели такая сложная задача ??? (гор.олимп) I уровень....
Ответ опубликую попозже (может кто и решит....),
задачка-то легкая.... :'(

Дай время...его как раз и не хватает

1 вариант, по условию:

Program Posled2;
Var
  l, m, n, i : byte;
  FIn, FOut  : text;
  Num        : array[1..100] of byte;
Begin
  assign(FIn,'input.txt');
  assign(FOut,'output.txt');
  reset(FIn);
  rewrite(FOut);
  l := 0;  {chet}
  m := 0;  {nechet}
  readln(FIn,n);
  for i := 1 to n   do begin
    read(FIn,Num[i]);
    if Num[i] mod 2 = 0 then
      inc(l)
    else
      inc(m);
  end;
  if (l=0) or (m=0) then
    write(FOut,0)
  else
    if l > m then
      for l := 1 to m   do begin
        i := 1;
        while (Num[i] mod 2 <> 0) or (Num[i]=100)   do
          inc(i);
        write(FOut,Num[i], ' ');
        Num[i] := 100;
        i := 1;
        while Num[i] mod 2 <> 1   do
          inc(i);
        write(FOut,Num[i], ' ');
        Num[i] := 100;
      end else
      for i := m to l   do begin
        i := 1;
        while (Num[i] mod 2 <> 0) or (Num[i]=100)   do
          inc(i);
        write(FOut,Num[i], ' ');
        Num[i] := 100;
        i := 1;
        while Num[i] mod 2 <> 1   do
          inc(i);
        write(FOut,Num[i], ' ');
        Num[i] := 100;
      end;
  close(FIn);
  close(FOut);
End.

2 вариант: n может быть больше, оно не указывается.

Program Posled1;
Var
  FIn, FOut, Fl, Fm : text;
  l, m              : longint;
  Num               : integer;
Begin
  assign(FIn,'input.txt');
  assign(FOut,'output.txt');
  assign(Fl,'l.txt');
  assign(Fm,'m.txt');
  reset(FIn);
  rewrite(FOut);
  rewrite(Fl);
  rewrite(Fm);
  readln(FIn,m);
  l := 0;  {chet}
  m := 0;  {nechet}
  while not(Eof(FIn))   do begin
    read(FIn,Num);
    if Num mod 2 = 0   then begin
      inc(l);
      write(Fl,Num, ' ');
    end else
    begin
      inc(m);
      write(Fm,Num, ' ');
    end;
  end;
  close(Fl);
  close(Fm);
  reset(Fl);
  reset(Fm);
  if (l=0) or (m=0) then
    write(FOut,0)
  else
    if l > m then
      for l := 1 to m   do begin
        read(Fl,Num);
        write(FOut,Num, ' ');
        read(Fm,Num);
        write(FOut,Num, ' ');
      end else
      for m := 1 to l   do begin
        read(Fl,Num);
        write(FOut,Num, ' ');
        read(Fm,Num);
        write(FOut,Num, ' ');
      end;
  close(Fl);
  close(Fm);
  close(FIn);
  close(FOut);
End.

В первой проге у тебя есть маленькая ошибка: если, например, нечетных чисел больше то у тебя не будет выполняться цикл for i:=m to l do, а вторая классно зделана не придерешся, а вот мой вариант:

program Posled_CHET_NECHET;
var
   f1,f2:text;
   i,r,g,f,j,n:integer;
   b,a:array[1..100] of byte;
begin
   assign(f1,'input.txt');
   assign(f2,'output.txt');
   reset(f1);
   rewrite(f2);
   readln(f1,n);
   for i:=1 to n do read(f1,a[i]);
   r:=1;i:=1;
   while i<=n do
   begin
            if a[i] mod 2=0 then
       begin
        b[r]:=a[i];
        r:=r+2;
       end;
       i:=i+1;
   end;
   g:=r-2;
   r:=2;i:=1;
   while n>=i do
   begin
      if odd(a[i]) then
      begin
       b[r]:=a[i];
       r:=r+2;
      end;
      i:=i+1;
   end;
   f:=r-2;
   if (g=-1) or (f=0) then write(f2,'0') else
   begin
      if f>=g then j:=g+1 else j:=f;
      for i:=1 to j do write(f2,b[i],' ');
   end;
   close(f1);
   close(f2);
end.

Я здесь использую дополнительный массив который заполняю сначала четными, а затем нечетными числами, ну а потом вывожу в файл то что надо.

В первой проге у тебя есть маленькая ошибка: если, например, нечетных чисел больше то у тебя не будет выполняться цикл for i:=m to l do, а вторая классно зделана не придерешся, а вот мой вариант:

это просто опечатка  for m := 1 to l и усё!
Спасибо за задачку ;)

Похоже, я с ответом запоздал немного... на месячишко-полтора но вот мое решение(короткое, но исп. ДВА доп. массива, что при таких ограничениях на их длины не фатально).

program Ivs_question;
var A, B, given: array[1..100] of Byte;
    i, n, k1, k2, k: byte;
    input, output: text;

function min(a,b: byte): byte;
begin if a < b then min:=a else min:=b end;

procedure init_vars;
begin k1:=1; k2:=1; k:=1;
  assign(input,'input.txt');reset(input);
  assign(output,'output.txt'); rewrite(output) end;

begin init_vars;
  ReadLn(N);
  for i:=1 to N do Read(input,given[i]);

  for i:=1 to N do
    if given[i] mod 2 = 1 then begin
        A[k1]:=given[i]; inc(k1) end
    else begin
        B[k2]:=given[i]; inc(k2) end;
  k:=min(k1, k2)-1;
  if k=0 then Write(output,k) else
     for i:=1 to k do Write(output,B[i],' ',A[i],' ');
  close(input); close(output)
END.

В Паскале чуть-чуть не влезает на один экран(25 строк) ;)