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

[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 вылетает. Возможно, есть более элегантное и правильное решение? =)

[klem4]

в общем вот грубый перебор Все приведенные тобой тесты программа прошла, на 200 чисел конечно такое решение врятли потянет, не пробовал, но думаю задумается прога надолго

{$R-}

uses crt;

type
  PTArray = ^TArray;
  TArray = array [1..1] of Integer;

  PTFlags = ^TFlags;
  TFlags  = array [1..1] of 0..1;
  TIdxSet = Set of Byte;

const
  MIN_SUM: Integer = 10001;
  group1: TIdxSet = [];
  group2: TIdxSet = [];

var
  arr: PTArray;
  size: Byte;
  flags1, flags2: PTFlags;


procedure shift_flags(var flags: PTFlags);
var
  i: Byte;
begin
  i := size + 1;

  repeat
    dec(i);
    inc(flags^[i]);
    if flags^[i] = 2 then
      flags^[i] := 0;
  until flags^[i] = 1;
end;

procedure print_flags(const flags: PTFlags);
var
  i: Byte;
begin
  writeln;
  for i := 1 to size do write(flags^[i]);
  writeln;
end;

function group_sum(const flags: PTFlags): Integer;
var
  i: Byte;
  _result: Integer;
begin
  _result := 0;

  for i := 1 to size do
   if flags^[i] = 1 then
     _result := _result + arr^[i];

  group_sum := _result;
end;

procedure copy_flags(const _from: PTFlags; var _to: PTFlags);
begin
  move(_from^, _to^, size);
end;

function unique_flags(const a, b: PTFlags): Boolean;
var
  i: Byte;
begin
  i := size;

  while (i > 0) and not (a^[i] * b^[i] = 1) do
    dec(i);

  unique_flags := (i = 0);
end;

procedure flags2set(const flags: PTFlags; var idx_set: TIdxSet);
var
  i: Byte;
begin
  idx_set := [];

  for i := 1 to size do
   if flags^[i] = 1 then
     include(idx_set, i);
end;

function final_query(const flags: PTFlags): Boolean;
var
  i: Byte;
begin
  i := 1;

  while (i <= size) and (flags^[i] = 1) do
    inc(i);

  final_query := (i > size);
end;

procedure get_solve;
var
  s1, s2: Integer;
  find: Boolean;
begin
  repeat
    shift_flags(flags1);

    s1 := group_sum(flags1);

    if (s1 < MIN_SUM) then begin
      copy_flags(flags1, flags2);

      find := false;

      repeat
        shift_flags(flags2);

        if unique_flags(flags1, flags2) then begin

          s2 := group_sum(flags2);

          if s1 = s2 then begin

            MIN_SUM := s1;

            flags2set(flags1, group1);
            flags2set(flags2, group2);

            find := true;

          end;
        end;
      until find or final_query(flags2);
    end;

  until final_query(flags1);
end;

var
  f: Text;
  i: Byte;

begin
  clrscr;

  assign(f, 'C:\input.txt');
  reset(f);

  readln(f, size);

  getmem(arr, size * sizeof(TArray));

  for i := 1 to size do begin
     readln(f, arr^[i]);
     write(arr^[i]:4);
  end;

  writeln;

  close(f);

  getmem(flags1, size * sizeof(TFlags));
  getmem(flags2, size * sizeof(TFlags));

  fillchar(flags1^, size * sizeof(TFlags), 0);

  copy_flags(flags1, flags2);

  get_solve;

  freemem(flags1, size * sizeof(TFlags));
  freemem(flags2, size * sizeof(TFlags));

  writeln;

  write('group1: ');

  for i := 1 to size do
   if i in group1 then write(arr^[i]:3, ',');

  writeln;

  write('group2: ');
  for i := 1 to size do
   if i in group2 then write(arr^[i]:3, ',');

  writeln;
  writeln;
  writeln('S = ', MIN_SUM);

  freemem(arr, size * sizeof(TArray));

  readln;
end.