Задача для разминки мозгов

← →
Сатир © (2002-12-25 14:49) [0]

есть ряд натуральных чисел от 1 до N
есть число K
Определить число комбинаций членов ряда, которые в сумме дадут K.
Рассмотреть все варианты.
Даю неделю на решение после чего будет оглашен результат победителя или одно из решений, если последнего не найдётся.
Победителю канхвета "Тузик"%)

← →
Рыжик © (2002-12-25 14:54) [1]

С учётом порядка или без?

← →
McSimm © (2002-12-25 15:06) [2]

Делал для студии звукозаписи программу и в ней был подбор вариантов компоновки треков с CD на кассету заданной длительности.

Неделю не могли поверить, что кассету можно точно (а была функция и приблизительного подбора) заполнить сотнями вариантов :)

← →
Сатир © (2002-12-25 15:25) [3]

2Рыжик © (25.12.02 14:54)
без
то есть
1+2+4=1+2+4=2+1+4=2+4+1=4+2+1=4+1+2
главное, чтоб сумма равнялась К, то есть нужно определить коллекцию множеств, образованных из членов этого ряда, составляющие которых дадут К

← →
Johnmen © (2002-12-25 17:35) [4]

>McSimm © (25.12.02 15:06)

Абсолютно то же самое писал неск.лет назад ! :)))))))

← →
Dona © (2002-12-25 17:45) [5]

Да, нам на 1 курсе подобную семестровую задавали :)

← →
Сатир © (2002-12-25 18:55) [6]

народ, харошь вспоминать приятные мелочи
лучше пусть кто-то решит, тогда и будем делить победителя

← →
Sha © (2002-12-25 20:51) [7]

2 Johnmen © (25.12.02 17:35)

Писали :)

← →
Jeer © (2002-12-25 20:54) [8]

Так огласи результ.
За премией дело не встанет.
Вспоможем-с.

← →
Igorek © (2002-12-25 21:23) [9]

> Сатир © (25.12.02 14:49)

А словами можно? ;-)

Значит так: делаем перебор всех возможных комбинаций заданного набора чисел обычным рекурсивным способом (недавно была ветка про перебор). По мере заполнения текущей комбинации вычисляем текущую сумму (она равна сумме уже использованных чисел в комбинации). Если текущая сумма превышает заданную, то данная ветка в полном дереве перебора бесперспективная (метод ветвей и границ). Если мы собрали комбинацию, то тогда если текущая сумма равна заданной, то делаем инкремент счетчика.

Счас MBo прочитает и реализует :-)))

← →
Сатир © (2002-12-25 22:02) [10]

2Jeer © (25.12.02 20:54)
ещё рано, я дал неделю на раздумия

2Igorek © (25.12.02 21:23)
рекурсия и деревья - это всё понятно, но вот когда N и K в районе миллиона, тогда станет вопрос об оптимальном решении

← →
Igorek © (2002-12-26 00:29) [11]

> Сатир © (25.12.02 22:02)
> 2Igorek © (25.12.02 21:23)
> рекурсия и деревья - это всё понятно, но вот когда N и K
> в районе миллиона, тогда станет вопрос об оптимальном решении

Ну так вопрос в том и состоит, что бы еще дельше оптимизировать алгоритм. Хотя я напр. не знаю как.

← →
Sha © (2002-12-26 10:06) [12]

2 Сатир © (25.12.02 14:49)

Неполное описание требований, не определен тестовый пример, не ясен критерий оценки...

Конкретизируй.

зы. А, что, есть такая конфета? Kexit gbdjv :)

← →
Alx2 © (2002-12-26 10:48) [13]

procedure TForm1.Button1Click(Sender: TObject); var Data: array of integer; Stop : Integer; function Solve(Level, Value: Integer): Boolean; var k, len: integer; begin Result := Value = 0; if Result then begin Memo1.Lines.Add("--------------"); for k := 0 to Length(Data) - 1 do Memo1.Lines.Add(IntToStr(Data[k])) end else begin Len := Length(data); SetLength(Data, Len + 1); for k := Level to Stop do begin Data[Len] := k; Solve(k + 1, Value - k); end; SetLength(Data, Len); end; end; begin Stop := 6; - Ограничитель "N" Solve(1, 10); В данном случае K=10 end;

PS
Динамический массив - затычка. Здесь лучше использовать статику

← →
Alx2 © (2002-12-26 11:05) [14]

Что-то на функцию я запал. Процедуры хватит, конечно же.
procedure TForm1.Button1Click(Sender: TObject); var Data: array of integer; Stop: Integer; procedure Solve(Level, Value: Integer); var k, len: integer; begin if Value = 0 then begin Memo1.Lines.Add("--------------"); for k := 0 to Length(Data) - 1 do Memo1.Lines.Add(IntToStr(Data[k])) end else begin Len := Length(data); SetLength(Data, Len + 1); for k := Level to Stop do begin Data[Len] := k; Solve(k + 1, Value - k); end; SetLength(Data, Len); end; end; begin Stop := 6; Solve(1, 10); end;

← →
Alx2 © (2002-12-26 11:52) [15]

И непосредственно ответ на задание:
"есть ряд натуральных чисел от 1 до N ... Определить число комбинаций членов ряда, которые в сумме дадут K. Рассмотреть все варианты."
procedure TForm1.Button1Click(Sender: TObject); var Stop: Integer; function SolveCount(Level, Value: Integer):Integer; Var k : Integer; begin Result := 0; if Value = 0 then inc(Result) else for k := Level to Stop do inc(Result,SolveCount(k + 1, Value - k)); end; begin // Определяем число комбинаций членов ряда, которые в сумме // дадут 10, если есть ряд натуральных чисел от 1 до 6 Stop := 6; ShowMessage(SolveCount(1, 10)); end;

← →
Sha © (2002-12-26 12:28) [16]

2 Alx2 © (26.12.02 11:52)

Надо, вероятно, чуть поправить, чтобы после Stop := 6; ShowMessage(SolveCount(1, 0));
было 0, а не 1.

А так - нормально. Правда, время расчетов для больших чисел будет просто огромным.

← →
Alx2 © (2002-12-26 12:49) [17]

>Sha © (26.12.02 12:28)
Просто нужен контроль входных данных.

У меня перебор "в лоб".

Можно решать еще так, например.
Количество таких разложений = коэфициенты при соответствующих степенях K в выражении (1 + x^1)*(1 + x^2)*(1 + x^3)...(1+x^N) после раскрытия скобок

← →
Sha © (2002-12-26 13:11) [18]

Alx2 © (26.12.02 12:49)

> Количество таких разложений = коэфициент при x^K в выражении
> (1 + x^1)*(1 + x^2)*(1 + x^3)...(1 + x^N) после раскрытия скобок.

Это очевидно. Осталось его найти :)

← →
Сатир © (2002-12-26 13:31) [19]

2Sha © (26.12.02 10:06)
>зы. А, что, есть такая конфета? Kexit gbdjv :)
отсылаю к творчеству Леся Подеревьянського
http://www.slovnyk.org/txt/poderev/_single/hamlet.html
"Пилите, Шура, пилите" (с)Ильф и Петров. "Золотой Телёнок"

2Alx2 © (26.12.02 12:49)
вообщем, Вы, судя по всему, очень близки к истине, но дадим ещё пару дней, может кто-то и предложет ещё несколько красивых решений

← →
Alx2 © (2002-12-26 13:33) [20]

>Sha © (26.12.02 13:11)
Ассимптоматика известна
a(n)~1/12*exp(1/12*pi*sqrt(144*n-6)*sqrt(3))*3^(3/4)/((n-1/24)^(3/4)) (результат не мой, естстественно. Но на что сослаться - не помню)

← →
Sha © (2002-12-26 13:40) [21]

2 Сатир © (26.12.02 13:31)

Kexit gbdjv :)

← →
Сатир © (2002-12-26 13:55) [22]

2Sha © (26.12.02 13:40)
ну, эт само собой:)

← →
Alx2 © (2002-12-26 14:24) [23]

>Сатир © (26.12.02 13:55)
>вообщем, Вы, судя по всему, очень близки к истине, но дадим ещё
>пару дней, может кто-то и предложет ещё несколько красивых
>решений

Халява, сэр :)) Но я польщен, хотя и не удосужился до истины дотянуться:) Кстати, на что вам сдались комбинаторные взрывы? (Это про "Рассмотреть все варианты", факториалы - рулез форева?)
И что породило такую задачу (воспитательные задачи от преподов - не аргумент)?

← →
Сатир © (2002-12-26 14:54) [24]

2Alx2 © (26.12.02 14:24)
решил тряхнуть стариной%)

← →
Sha © (2002-12-26 15:16) [25]

Мой вариант: procedure TForm1.Button3Click(Sender: TObject); function SolveCount(MaxNo, Sum: Integer):Integer; var No: integer; begin; Result:=0; for No:=MaxNo downto 1 do if No=Sum then inc(Result) else if No<Sum then inc(Result,SolveCount(No-1, Sum-No)); end; begin; ShowMessage(IntToStr(SolveCount(32, 32))+" "+IntToStr(Ct)); end;

Он корректно обрабатывает нулевую сумму и значительно эффективнее на больших числах, хотя тоже не подарок.

← →
Sha © (2002-12-26 15:20) [26]

+" "+IntToStr(Ct) надо удалить - замерял произодительность.

← →
Alx2 © (2002-12-26 15:27) [27]

>Sha © (26.12.02 15:16)
>и значительно эффективнее на больших числах, хотя тоже не
>подарок.

Да.. разница на порядки. Надо же, я как тот пост написал, то и думать над задчкой перестал а надо было бы. Теперь придется переплевывать, что вряд ли получится :))

← →
Sha © (2002-12-26 17:03) [28]

Более эффективный (примерно в 2 раза), хотя и менее красивый вариант: procedure TForm1.Button4Click(Sender: TObject); function SolveCount(No, Sum: integer): integer; begin; Result:=0; if No>=Sum then begin; inc(Result); No:=Sum-1; end; while No>1 do begin; inc(Result,SolveCount(No-1, Sum-No)); dec(No); end; end; begin; ShowMessage(IntToStr(SolveCount(25, 25))); end;

type TByteSet=set of byte; const n=20; m=60; ... procedure TForm1.Button1Click(Sender: TObject); var b,bmin:byte; nn:cardinal; nfull:int64; function MinByte(b1:Byte;b2:Cardinal):Byte; begin if b1>b2 then Result:=byte(b2) else Result:=b1; end; procedure PrintSet(BSet:TByteSet); var bb,cb:byte; s:string; nf:cardinal; begin inc(nn); cb:=0; s:=""; for bb:=1 to n do if bb in BSet then begin s:=s+Format("%-3d",[bb]); inc(cb); end; Memo1.Lines.Add(s); nf:=1; for bb:=2 to cb do nf:=nf*bb; inc(nfull,nf); end; procedure FindIt(StartSet,SumSet:TByteSet; Sum:Integer); var bb:byte; begin for bb:=1 to bmin do if bb in StartSet then begin Exclude(StartSet,bb); if bb=Sum then PrintSet(SumSet+[bb]) else if bb<Sum then FindIt(StartSet,SumSet+[bb],Sum-bb); end; end; begin Memo1.Clear; bmin:=MinByte(n,m); nn:=0; nfull:=0; Memo1.Lines.BeginUpdate; for b:=1 to bmin do FindIt([b+1..bmin],[b],m-b); Memo1.Lines.EndUpdate; Memo1.Lines.Add("Variants: "+IntToStr(nn)); Memo1.Lines.Add("With permutations: "+IntToStr(nfull)); end;

чуть быстрее
procedure FindIt(StartSet,SumSet:TByteSet; Sum:Integer); var bb:byte; begin for bb:=1 to bmin do if bb in StartSet then begin Exclude(StartSet,bb); Include(SumSet,bb); if bb=Sum then PrintSet(SumSet) else if bb<Sum then FindIt(StartSet,SumSet,Sum-bb); Exclude(SumSet,bb); end; end;

service pack #2 ;)
if bb=Sum then PrintSet(SumSet) else if bb<Sum then FindIt(StartSet,SumSet,Sum-bb) else Break;

Я тут немного поразмыслил - и резвость проги повысилась еще в два раза.
Теперь на моем 500 MHz компьютере расчет SolveCount(200,200) занимает чуть более 1 минуты (а это ~500.000.000 вариантов). Т.е. реально с ее помощью точно вычислять значения вплоть до MaxInt. По-моему, этого достаточно.

Кому мало - скажу: есть еще очень серьезные резервы (намек содержится в измененном тексте программы), но для их использования потребуется перевести программу в другую весовую категорию. function SolveCount(No, Sum: integer): integer; begin; Result:=0; case (((No+1)*No) shr 1)-Sum of 0..2: Result:=1; 3: Result:=2; 4..MaxInt: begin; if No>=Sum then begin; inc(Result); No:=Sum-1; end; while No>1 do begin; inc(Result,SolveCount(No-1, Sum-No)); dec(No); end; end; end; end;

2Sha © (27.12.02 08:42)
Отлично

2All
Тогда предлагается из предложенных вариантов путём незначительных изменений предложить самый шустрый вариант
Успехов

2 ALL
Вообщем, ситауция такая: мой коллега по работе дал мне эту задачку, я её с горем пополам решил, и потом встал вопрос оптимизации.
В соревнованиях участвуют
1)Solaris, Ultra Spark 500 Mhz один камень -это у моего коллеги
2)Пень 450 Мгц - это у меня + ваши идеи;)
Вообщем, кто быстрее

2MBo © (26.12.02 18:14)
у человека на спарке, который раза в четыре медленее моего пня, правда написано на сях, работает при k=215, n=32 моментально, а у меня думает:(
обидно:)

>Сатир
В чем конкретно задача, что делает его программа?
Получить и вывести список вариантов или просто посчитать их?

2 Сатир © (27.12.02 17:57)

Применение кривого (параболического) зеркала увеличивает производительность еще на четверть:
50 сек. для k=200, n=200 на 500 MHz,
~2 сек. для k=215, n=32 на 500 MHz. function SolveCount(No, Sum: integer): integer; var SumMax: integer; begin; Result:=0; SumMax:=(((No+1)*No) shr 1); if Sum<=SumMax then begin; dec(SumMax,Sum); if Sum>SumMax then Sum:=SumMax; if Sum<5 then Result:=(Sum+5) shr 2 else begin; if No>=Sum then begin; inc(Result); No:=Sum-1; end; while No>1 do begin; inc(Result,SolveCount(No-1, Sum-No)); dec(No); end; end; end; end;

Этот алгоритм можно еще оптимизировать:
1. использовать заранее расчитанные таблицы, чтобы устранить толчею на малых числах,
2. запоминать результаты предыдущих вычислений, чтобы не вычислять повторно одно и то же,
3. переписать на Asm.

Дальше двигаться можно уже самостоятельно :)

Задача для разминки мозгов Найти похожие ветки