Форум: "Потрепаться";
Текущий архив: 2003.01.16;
Скачать: [xml.tar.bz2];
Вниз
Задача для разминки мозгов Найти похожие ветки
← →
Сатир (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;
← →
MBo (2002-12-26 18:09) [29]
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;
← →
MBo (2002-12-26 18:14) [30]чуть быстрее
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;
← →
MBo (2002-12-26 18:19) [31]service pack #2 ;)
if bb=Sum then
PrintSet(SumSet)
else
if bb<Sum then
FindIt(StartSet,SumSet,Sum-bb)
else Break;
← →
Сатир (2002-12-26 19:14) [32]2MBo © (26.12.02 18:19)
Спасибо за ответы
Рад Вас видеть
← →
Sha (2002-12-27 08:42) [33]Я тут немного поразмыслил - и резвость проги повысилась еще в два раза.
Теперь на моем 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;
← →
Сатир (2002-12-27 13:56) [34]2Sha © (27.12.02 08:42)
Отлично
2All
Тогда предлагается из предложенных вариантов путём незначительных изменений предложить самый шустрый вариант
Успехов
← →
Novice (2002-12-27 14:14) [35]2 Сатир © (27.12.02 13:56)
A потом самый шустрый из самых шустрых :)
← →
Сатир (2002-12-27 15:26) [36]2Novice © (27.12.02 14:14)
я могу взять на себя роль жюри и вынести окончательного победителя
← →
Сатир (2002-12-27 17:01) [37]2 ALL
Вообщем, ситауция такая: мой коллега по работе дал мне эту задачку, я её с горем пополам решил, и потом встал вопрос оптимизации.
В соревнованиях участвуют
1)Solaris, Ultra Spark 500 Mhz один камень -это у моего коллеги
2)Пень 450 Мгц - это у меня + ваши идеи;)
Вообщем, кто быстрее
← →
Сатир (2002-12-27 17:57) [38]2MBo © (26.12.02 18:14)
у человека на спарке, который раза в четыре медленее моего пня, правда написано на сях, работает при k=215, n=32 моментально, а у меня думает:(
обидно:)
← →
MBo (2002-12-27 18:02) [39]>Сатир
В чем конкретно задача, что делает его программа?
Получить и вывести список вариантов или просто посчитать их?
← →
Sha (2002-12-27 18:26) [40]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.
Дальше двигаться можно уже самостоятельно :)
← →
Sha (2002-12-27 20:26) [41]Убрал умножения и рекурсивные обращения за нулевым результатом.
Шустрость повысилась на 40% :
30 сек. для k=200, n=200 на 500 MHz,
1.3 сек. для k=215, n=32 на 500 MHz.
procedure TForm1.Button18Click(Sender: TObject);
var
Ticks: integer;
Count: integer;
function SolveCount2(No, Sum: integer): integer;
var
Sq: array[1..1000] of integer;
SqNo: integer;
function SolveCount(No, Sum: integer): integer;
begin;
Result:=0;
if Sum>Sq[No]-Sum then Sum:=Sq[No]-Sum;
if Sum<5 then Result:=(Sum+5) shr 2
else begin;
if No>=Sum then begin;
inc(Result);
No:=Sum-1;
end;
while Sq[No]>=Sum do begin;
inc(Result,SolveCount(No-1, Sum-No));
dec(No);
end;
end;
end;
begin;
Result:=0;
if (No>0) and (Sum>0) and (Sum<=(No*(No+1)) shr 1) and (No<High(Sq)) then begin;
for SqNo:=1 to No do Sq[SqNo]:=(SqNo*(SqNo+1)) shr 1;
Result:=SolveCount(No, Sum);
end;
end;
begin;
Ticks:=GetTickCount;
//Count:=SolveCount2(200, 200);
Count:=SolveCount2(32, 215);
Ticks:=GetTickCount-Ticks;
ShowMessage(IntToStr(Count)+" "+IntToStr(Ticks));
end;
← →
Sha (2002-12-27 23:33) [42]Близится конец отпущенного срока... А решения все нет...
Представляю главного претендента, выступающего в тяжелой весовой категории.
function SolveCount(No, Sum: integer): integer;
var
Cnt: array of integer;
CntX, NoX, Sum1, Sum2, SumX: integer;
begin;
if (No<=0) or (Sum<=0) or (Sum>(No*(No+1)) shr 1) then Result:=0
else begin;
if No>Sum then No:=Sum;
SetLength(Cnt,((No*(No+1)) shr 1)+1);
Sum2:=0; Cnt[0]:=1;
for NoX:=1 to No do begin;
Sum1:=Sum2; inc(Sum2,NoX);
for SumX:=Sum2 downto NoX do begin;
CntX:=Cnt[SumX-NoX];
if SumX<=Sum1 then inc(CntX,Cnt[SumX]);
Cnt[SumX]:=CntX;
end;
end;
Result:=Cnt[Sum];
Cnt:=nil;
end;
end;
Все будет посчитано за несколько миллисекунд.
Первый догадается, как это делается, получает половину обещанного приза :)
← →
Sha (2002-12-28 10:33) [43]Полученное решение имеет смысл оптимизировать по памяти. Можно использовать применявшиеся ранее методы оптимизации (зеркало, отсечение угла и отсечение основания). Это даст также некоторый прирост производительности.
Вариант решения, приведенный ниже, за несколько миллисекунд вычисляет 64-битный результат для любого No при затратах памяти ~8*Sum байт.
procedure TForm1.Button19Click(Sender: TObject);
type
TSolveCount= int64;
var
Count: TSolveCount;
Ticks: integer;
function SolveCount(No, Sum: integer): TSolveCount;
var
Cnt: array of TSolveCount;
NoX, Sum1, Sum2, Sum3, SumX: integer;
begin;
Sum2:=(No*(No+1)) shr 1;
if (No<=0) or (Sum<=0) or (Sum>Sum2) then Result:=0
else begin;
repeat;
if Sum>Sum2-Sum then Sum:=Sum2-Sum;
if No>Sum then No:=Sum;
Sum1:=Sum2;
Sum2:=(No*(No+1)) shr 1;
until Sum1=Sum2;
SetLength(Cnt,Sum+1);
Sum2:=0; Cnt[0]:=1;
for NoX:=1 to No do begin;
Sum1:=Sum2; inc(Sum2,NoX); if Sum2<Sum then Sum3:=Sum2 else Sum3:=Sum;
for SumX:=Sum3 downto NoX do
if SumX>Sum1
then Cnt[SumX]:=Cnt[SumX-NoX]
else inc(Cnt[SumX],Cnt[SumX-NoX]);
end;
Result:=Cnt[Sum];
Cnt:=nil;
end;
end;
← →
Сатир (2002-12-28 13:27) [44]2Sha © (27.12.02 18:26)
мой коллега мне сказал, что бутылочным горлышком является использование рекурсии. Эту задачу, оказывается, можно решить без неё, так что лучше измени алгоритм, чем улучшай старый. Само использование рекурсии даёт большую задержку в вычислениях. По его словам, все берутся решать эту задачу сначала через рекурсию и решают в последствии, но для большых чисел это очень медлительный метод.
Теперь осталось выяснить, есть ли у кого идеи, как решить его без использования алгоритма рекурсии.
← →
Sha (2002-12-28 19:47) [45]2 Сатир © (28.12.02 13:27)
А где тут рекурсия?
Смотри внимательно Sha © (28.12.02 10:33).
Находит решение за 0 тиков.
← →
Сатир (2002-12-28 19:57) [46]2Sha © (28.12.02 19:47)
снимаю шляпу, потерял бдительность:(, стар, супер-стар
"За премией дело не встанет."Jeer © (25.12.02 20:54)
Вспоможем-с.
← →
Сатир (2002-12-28 20:35) [47]2Sha © (28.12.02 19:47)
ладно, а теперь посчитайте своё творение при 10000, 10000.
Получим переполнение стека:(. Есть идеи как это обойти?
← →
Sha (2002-12-28 20:50) [48]Не стека, а разрядной сетки. Для заданного No максимум значения функции приходится на Sum=(No*(No-1)) shr 2. Даже 64-битных чисел хватает только на вычисления без переполнения до No=71.
← →
Сатир (2002-12-28 20:53) [49]2Sha © (28.12.02 20:50)
сорри, грешу понятиями
а коду отсыпите?
← →
Sha (2002-12-28 20:56) [50]Длинные числа имеются ввиду? Этого добра везде навалом. Поищи.
← →
Сатир (2002-12-28 20:59) [51]2Sha © (28.12.02 20:56)
та ну, преобразовывать в строку... нам такое давали на школьной олимпиаде по информатике
А коллега грит, что напишет это на питоне, там можно задавать целые до бесконечности... вот так.
← →
Sha (2002-12-28 21:02) [52]Какие строки? Зачем? Посмотри реализацию типа int64 через тип integer.
← →
Сатир (2002-12-28 21:16) [53]ушёл посмотреть
Страницы: 1 2 вся ветка
Форум: "Потрепаться";
Текущий архив: 2003.01.16;
Скачать: [xml.tar.bz2];
Память: 0.58 MB
Время: 0.01 c
