Нахождение двух минимальных сумм чисел Опции

[S_lip]

Здравствуйте!
Вот такая задачка:

Дана упорядоченная последовательность N чисел. (2<=N<=200). Каждое число больше 0, но меньше 30000. Нужно из этого ряда найти два набора чисел, величины которых должны быть равны и минимальны. Гарантируется, что эта величина будет меньше 100000. Эту величину нужно выписать.

Примеры:
Дано: 1 2 3 4 5. Группы чисел: 1 2 и 3. Ответ: 3.
Дано: 1 2 5 5 8 10 102. Группы чисел: 5 и 5. Ответ: 5.
Дано: 2 3 4 5. Группы чисел: 2 3 и 5. Ответ: 5.
Дано: 1 3 5 7 13 21. Группы чисел: 1 7 и 3 5. Ответ: 8.
Дано: 1 2 5 8 14. Группы чисел: 1 2 5 и 8. Ответ: 8.


Вот я придумал вот такое решение:
http://img401.imageshack.us/img401/500/20308125la9.png

const
  MaxCount=200;
  MaxSum=100000;
type
  pair=record
    l,r:longint;
  end;
var
  a:array [1..MaxCount] of integer;
  b:array [0..50000] of pair; //чтоб хватило
  f:text;
  n,i,j,k,d:integer;
begin
  assign(f,'file.in');
  reset(f);
  readln(f,n);
  for i:= 1 to n do readln(f,a[i]);
  close(f);

  d:=0;
  repeat
    inc(d);
    b[0].l:=a[d];
    b[0].r:=0;
    i:=1;
    k:=d;

    repeat
      inc(k);
      for j:= 0 to (i-1) do begin
        b[j+i].l:=b[j].l;
        b[j+i].r:=b[j].r+a[k];
        inc(b[j].l , a[k]);
      end;
      j:=1;
      inc(i,i);
      while (j<=i) and (b[j-1].l<>b[j-1].r) do inc(j);
    until(j<=i) or (b[0].l>MaxSum)

  until j<=i;
  
  writeln(b[j-1].l);
end.

Программа перебирает все возможне пары сначало с участием первого числа. Если сумма этих пар больше 100000, а равные величины так и не найдены, то перебирает все возможные пары с участием второго числа и т.д.

Это решение кушает очень много памяти и при большом N вылетает. Возможно, есть более элегантное и правильное решение? =)

[S_lip]

Michael_Rybak, спасибо за пример.
Вот исправленный код:

const
  MaxCount=200;
  MaxSum=100000;
type
  posanddif=record
    c,d:longint;
  end;
var
  a:array [1..MaxCount] of integer;
  n:byte;
  u,d:array [1..(MaxSum div 2)] of longint;
  udn:longint;
  b:array [0..(MaxSum div 2)] of longint;
  pad:array [1..(MaxSum div 2)] of posanddif;
  pn:longint;
  f:text;
  i,j:longint;

procedure ProcessUD(uu,dd:longint);
var
  ii:longint;
begin
  if dd<=(MaxSum div 2) then begin
    if b[dd-uu]>0 then begin
      if u[b[dd-uu]]>uu then begin
        ii:=1;
        while (ii<=pn) and (pad[ii].c<>b[dd-uu]) do inc(ii);
        if ii>pn then begin
          inc(pn);
          pad[pn].c:=b[dd-uu];
          pad[pn].d:=u[b[dd-uu]]-uu;
        end else if pad[ii].d>u[b[dd-uu]]-uu then
          pad[ii].d:=u[b[dd-uu]]-uu;
      end;
    end else begin
      inc(udn);
      u[udn]:=uu;
      d[udn]:=dd;
      b[dd-uu]:=udn;
    end;
  end;
end;

begin
  assign(f,'file.in');
  reset(f);
  readln(f,n);
  for i:= 1 to n do
    readln(f,a[i]);
  close(f);

  for i:= 0 to (MaxSum div 2) do b[i]:=0;
  udn:=1;
  i:=1;
  u[1]:=0;
  d[1]:=a[1];
  b[a[1]]:=a[1];

  for i:= 2 to n do begin

    pn:=0;
    j:=udn;

    ProcessUD(0,a[i]);

    for j:= 1 to j do begin
      ProcessUD(u[j],d[j]+a[i]);
      if u[j]+a[i]<d[j] then ProcessUD(u[j]+a[i],d[j])
      else ProcessUD(d[j],u[j]+a[i]);
    end;

    for j:= 1 to pn do begin
      dec(u[pad[j].c],pad[j].d);
      dec(d[pad[j].c],pad[j].d);
    end;

  end;
  writeln(u[b[0]]); //ответ
end.

Главное отличие - обходим все элементы, а также убрана медленная проверка в конце главного цикла и добавлен массив pad, который содержит позицию "с" и разницу "d" тех элементов, для которых мы нашли замену.
Этот пример также навел на мысль, что максимальное количество перебираемых чисел будет не 15 и не 16, а... 7502 (1 15000 15002 15004 ... 29998 29999). Поэтому нужно перебирать все n. Однако прога не справилась с примером из 200 чисел (1 200 202 204 ... 594 595). udn выходит за пределы 50000. Ошибка 201. Я потратил достаточно много времени, чтобы найти, где промах, но безуспешно.
Этот пример в 200 чисел прикреплен.

Сообщение отредактировано: S_lip - 31.12.2007 21:00