IMHO.WS - Задача о рюкзаке, ПОМОГИТЕ!!!

IMHO.WS (http://www.imho.ws/index.php)

- Программирование (http://www.imho.ws/forumdisplay.php?f=40)

- - Задача о рюкзаке, ПОМОГИТЕ!!! (http://www.imho.ws/showthread.php?t=62817)

Задача о рюкзаке, ПОМОГИТЕ!!!

Нужна программа (исходник, желательно на си или паскале) решающая задачу о рюкзаке:
X=(1,2,3,...,N), A принадлежит множеству {0, 1};
sum(X[i]*a[i])=s;
Найти подпоследовательности размерности K (K<=N), сумма которых была бы равной S.

Помогите пожалуйста, а то экзамен завалю!!!

А подробнее можно? Что за задача о рюкзаке?

Andy1

Может попроще расскажешь?. Размерность это сама одна большая задача :)
Расскажи детально.

Вот по-другому:
Алгоритм решает задачу о рюкзаке, которая формулируется так: дан, упорядоченный по неубыванию, массив A вещественных положительных чисел и некоторое Sum, необходимо найти все подпоследовательности массива A, сумма элементов которых равна в точности Sum.
В результате работы алгоритма получаем переменную L равную количеству найденых последовательностей. Сами последовательности помещаются в масcив строк Results, каждая строка представляет номера элементов массива A, разделенные запятыми.

В нете много ссылок на алгоритмы, а самой проги нет:(
Вот ссылка, например: http://alglib.manual.ru/combinatorial/backpack.php

Вот ещё кое-что: http://www.isu.ru/~slava/teach/school/comb_ret.htm
Просто сам уже не успеваю прогу написать, теории учить ещё до фига!

Если чё, я в асе: 86835583

Можно, чтобы она(прога) работала по неоптимальному алгоритму, главное, чтобы работала и была не слишком запутана!

Andy1
Задача о рюкзаке немного отличается от описанной тобой задачи.

Задача о рюкзаке:
Есть некоторое количество предметов, которые можно уложить в рюкзак. Для каждого предмета указан коэффициент полезности и его объем. Собрать рюкзак так, чтобы объем предметов не превышал указанный объем рюкзака и суммарная полезность предметов была максимальной.

За неимением Pascal'я код на VisualBasic'е ...

Код:

 Public Sub Main()

  ' Определение переменных и заполнение массивов

  Dim X(), A() As Byte

  Dim Res() As String

  Dim N, Sum, tSum, I As Byte

  N = 5 ' n - размерность массива (последовательности)

  ReDim X(N) ' X() - массив (последовательность) чисел

  ReDim A(N) ' A() - принимает значени 0 или 1 взависимости от того, входит данный элемент в сумму или нет

  ReDim Res(2 ^ N) ' Res() - результирующие последовательности

  ' заполняем массив произвольным образом

  X(1) = 1 : X(2) = 2 : X(3) = 2 : X(4) = 3 : X(5) = 3

  Sum = 6 ' s - сумма

  ' вводные данные закончились, теперь расчет

  A(1) = 0 : A(2) = 0 : A(3) = 0 : A(4) = 0 : A(5) = 0

  tSum = 0

  If tSum = Sum Then

   Call Save(Res, A, N)

  End If

  For I = 1 To N

   A(I) = 1

   Call Summ(Sum, tSum, I, X, A, Res, N)

   A(1) = 0 : A(2) = 0 : A(3) = 0 : A(4) = 0 : A(5) = 0

  Next

  I = 1

  While Len(Res(I)) > 0 And I <= 2 ^ N

   MsgBox(Res(I))

   I = I + 1

  End While

 End Sub



 Public Sub Main()

  ' Определение переменных и заполнение массивов

  Dim X(), A() As Byte

  Dim Res() As String

  Dim N, Sum, tSum, I, Count As Byte

  N = 5 ' n - размерность массива (последовательности)

  ReDim X(N) ' X() - массив (последовательность) чисел

  ReDim A(N) ' A() - принимает значени 0 или 1 взависимости от того, входит данный элемент в сумму или нет

  ReDim Res(2 ^ N) ' Res() - результирующие последовательности

  ' заполняем массив произвольным образом

  X(1) = 1 : X(2) = 2 : X(3) = 2 : X(4) = 3 : X(5) = 3

  Sum = 6 ' s - сумма

  ' вводные данные закончились, теперь расчет

  Count = 0

  A(1) = 0 : A(2) = 0 : A(3) = 0 : A(4) = 0 : A(5) = 0

  tSum = 0

  If tSum = Sum Then

   Count = Count + 1

   Call Save(Res, A, N)

  End If

  For I = 1 To N

   A(I) = 1

   Call Summ(Sum, tSum, I, X, A, Res, N, Count)

   A(1) = 0 : A(2) = 0 : A(3) = 0 : A(4) = 0 : A(5) = 0

  Next

  MsgBox(Trim(Str(Count)))

  I = 1

  While Len(Res(I)) > 0 And I <= 2 ^ N

   MsgBox(Res(I))

   I = I + 1

  End While

 End Sub



 Public Sub Summ(ByVal Sum As Byte, ByVal tSum As Byte, ByVal tI As Byte, ByVal X() As Byte, ByRef A() As Byte, ByRef Res() As String, ByVal N As Byte, ByRef Count As Byte)

  Dim ttSum As Byte

  Dim sI As Byte

  ttSum = tSum + X(tI)

  If ttSum < Sum Then

   For sI = tI + 1 To N

    A(sI) = 1

    Call Summ(Sum, ttSum, sI, X, A, Res, N, Count)

    A(sI) = 0

   Next

  ElseIf ttSum = Sum Then

   Count = Count + 1

   Call Save(Res, A, N)

  Else

   A(tI) = 0

  End If

 End Sub



 Public Sub Save(ByRef Res() As String, ByVal A() As Byte, ByVal N As Byte)

  Dim Max_I, tI As Byte

  For tI = 1 To 2 ^ N

   If Len(Trim(Res(tI))) = 0 Then

    Max_I = tI

    Exit For

   End If

  Next

  Res(Max_I) = "{"

  For tI = 1 To N

   If A(tI) = 1 Then

    If tI > 1 And Len(Res(Max_I)) > 1 Then

     Res(Max_I) = Res(Max_I) & ","

    End If

    Res(Max_I) = Res(Max_I) & Trim(Str(tI))

   End If

  Next

  Res(Max_I) = Res(Max_I) & "}"

 End Sub

Pascal последний раз юзал лет 6-7 назад, поэтому не судите строго ;)

Код:

uses crt;



 const n=5;

 const nn=32; {nn=2^n}



 function stepen(x,y : integer) : integer;

 begin

  if y=0 then

   stepen:=1

  else

   if y=1 then

    stepen:=x

   else

    begin

     y:=y-1;

     stepen:=x*stepen(x,y);

    end;

 end;



 procedure save(var res : array of string; a : array of integer);

 var max_i, ti : integer;

            zz : string;

 begin

  max_i:=0;

  for ti:=0 to stepen(2,n)-1 do

   if (length(res[ti])=0) and (max_i=0) then

    max_i:=ti;

  res[max_i]:='{';

  for ti:=0 to n-1 do

   if a[ti]=1 then

    begin

     if (ti>0) and (length(res[max_i])>1) then

      res[max_i]:=res[max_i]+',';

     str(ti+1,zz);

     res[max_i]:=res[max_i]+zz;

    end;

  res[max_i]:=res[max_i]+'}';

 end;



 procedure summ(sum,tsum,ti : integer; var count : integer;x:array of integer;var a:array of integer;var res:array of string);

 var ttsum, si : integer;

            zz : string;

 begin

  ttsum:=tsum+x[ti];

  if ttsum<sum then

   for si:=ti+1 to n-1 do

    begin

     a[si]:=1;

     summ(sum,ttsum,si,count,x,a,res);

     a[si]:=0;

    end

  else

   if ttsum=sum then

    begin

     count:=count+1;

     save(res,a);

    end

   else

    a[ti]:=0;

 end;



 var sum, tsum, i, count : integer;

                      zz : string;

                    x, a : array[0..n-1] of integer;

                     res : array[0..nn-1] of string;

begin

 clrscr;

 x[0]:=1; x[1]:=2; x[2]:=2; x[3]:=3; x[4]:=3;

 sum:=6;

 count:=0;

 a[0]:=0; a[1]:=0; a[2]:=0; a[3]:=0; a[4]:=0;

 tsum:=0;

 if tsum=sum then

  begin

   count:=count+1;

   save(res,a);

  end;

 for i:=0 to n-1 do

  begin

   a[i]:=1;

   summ(sum,tsum,i,count,x,a,res);

   a[0]:=0; a[1]:=0; a[2]:=0; a[3]:=0; a[4]:=0;

  end;

 writeln;

 str(count,zz);

 writeln('Count of SubArrays = '+zz);

 i:=1;

 if count>0 then

  writeln;

 for i:=1 to count do

  begin

   writeln(res[i]);

  end;

 readkey;

end.

В архиве сам файл :)

А на паскале прога та же написана, что и на vb?
Какую задачу она решает: твою или вмоей формулировке?

SwiMMeR, а зачем функция возведения в степень? а через exp (экспонента) слабо? :)
Andy1, это в твоей формулировке

dex0r
А через экспоненту это как?

exp(x) = e^x
а мне надо 2^x :confused:

SwiMMeR
Если не ошибаюсь, a^x = e ^ (x * ln(a))

ну вы замудрили! Осталось ещё через силу ветра :)

Цитата:

Сообщение от Andy1

А на паскале прога та же написана, что и на vb?
Какую задачу она решает: твою или вмоей формулировке?

На Паскале -- судя по всему в твоей формулировке.
Имнсхо, твоя задача NPC. Так что не стесняйся полного
перебора, принципиально лучшего алгоритма нет :)

dmkr
Полный перебор не подходит, т.к. не соответствует условиям задачи ... :) незря ведь там сказано

Цитата:

упорядоченный по неубыванию

;)

Ghost, асболютно точно :)
SwiMMeR, упс... а я не заметил :)

помогите решить задачу о рюкзаке на Builder желательно с помощью генетического алгоритма, очень нужно!!! если че пишите в аську 631504528

помогите,пожалуста

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