Re: need a function for sums of subsets

*To*: mathgroup at smc.vnet.net*Subject*: [mg33027] Re: [mg33001] need a function for sums of subsets*From*: Andrzej Kozlowski <andrzej at tuins.ac.jp>*Date*: Tue, 26 Feb 2002 04:35:17 -0500 (EST)*Sender*: owner-wri-mathgroup at wolfram.com

I have noticed some serious mistakes in my backtracking solution. First a minor one, the local variable k should be set to Length[L] not Length[L]+1. More seriously the code I sent is only correct in the case when the list (myrationals) contains only distinct elements. In that case findsum[L_, m_] := DeleteCases[Module[{sp, L1 = Prepend[L, 0], l, k = Length[L]}, sp = Table[L1, {k}]; partialQ = Compile[{{l, _Integer, 1}}, If[Length[l] == 1, True, Plus @@ l â?¤ m && Plus @@ l + (k - Length[l])*Max[L] â?¥ m && If[l[[-1]] > 0, (l[[-1]] > l[[-2]]), True]]]; solutionQ = Compile[{{l, _Integer, 1}}, Plus @@ l == m]; Backtrack[sp, partialQ, solutionQ, One]], 0]; findsum[L_,m_]/;Not[FreeQ[L,Rational]]:= Module[{d},d=LCM@@Denominator[Append[L,m]];findsum[d *L,d*m]/d] works fine. However, when the list contains non-distinct elements the backtracking code I gave earlier was completely wrong. The following version seems to be correct: findsum[L_, m_] := DeleteCases[ Module[{sp, L1 = Prepend[L, 0], l, k = Length[L]}, sp = Table[L1, {k}]; partialQ = Compile[{{l, _Integer, 1}}, If[Length[l] == 1, True, Plus @@ l <= m && Plus @@ l + (k - Length[l])* Max[L] >= m && If[l[[-1]] > 0, Which[Count[l, l[[-1]]] > Count[L, l[[-1]]], False, Count[l, l[[-1]]] == Count[L, l[[-1]]], l[[-1]] > l[[-2]], True, l[[-1]] >= l[[-2]]], True]]]; solutionQ = Compile[{{l, _Integer, 1}}, Plus @@ l == m]; Backtrack[sp, partialQ, solutionQ, One]], 0] findsum[L_, m_] /; !FreeQ[L, Rational] := Module[{d}, d = LCM @@ Denominator[Append[L, m]]; findsum[d*L, d*m]/d] I should also add that the performance of findsum and findsum1 depends greatly on "luck", meaning particular inputs. While it seems quite difficult to compare the average running times, the tests I have made suggest that the backtracking approach is generally faster in a single run while findsum1 is faster in repeated runs. However, for a list with 100 elements, the worst case (no solution) in either case takes longer than I have the patience to wait. Andrzej Kozlowski Toyama International University JAPAN http://platon.c.u-tokyo.ac.jp/andrzej/ On Monday, February 25, 2002, at 01:39 PM, Andrzej Kozlowski wrote: > After I sent the message below it occurred to me to try an recursive > approach. It appears to be considerably faster but runs a risk of > running out of memory. Still, if your lists are only as long as about > 100 elements it should be fine. Note that it gives a different answer > than the other approach in cases when there are multiple solutions. > > In[41]:= > findsum1[L_, m_] := findsum1[L, m] = Module[{u}, If[Plus @@ L == m, L, > Do[If[(u = findsum1[Drop[L, {i}], m]) != {}, Return[u]], {i, 1, > Length[L]}]]] > > In[42]:= > findsum1[L_, m_] /; Length[L] == 1 := If[L[[1]] == m, L, {}] > > We need to increase > > $RecursionLimit = 10000 > > Let's compare the two functions on a random list: > > In[49]:= > myrationals=Table[Random[Integer,{1,10}],{100}]; > > In[50]:= > m=26; > > In[51]:= > findsum[myrationals,m]//Timing > > Out[51]= > {5.35 Second,{7,9,10}} > > In[52]:= > findsum1[myrationals,m]//Timing > > Out[52]= > {0.04 Second,{10,7,9}} > > Quite a difference in speed! > > > > > > On Monday, February 25, 2002, at 12:32 PM, Andrzej Kozlowski wrote: > >> It seems to me that this is just the sort of problem for which you >> should use the technique known as "backtracking". The most efficient >> way is to write your own backtracking program. But as that can be >> tricky and time consuming another approach is to use the Backtrack >> function from the DiscreteMath`Combinatorica` package. One can achieve >> some speed up by partially compiling this function. Here is the code >> that does that: >> >> Off[General::"spell"]; Off[General::"spell1"]; >> >> Backtrack[space_List,partialQ_,solutionQ_,flag_:One] := >> Module[{n=Length[space],all={},done,index,v=2,solution}, >> index=Prepend[ Table[0,{n-1}],1]; >> While[v > 0, >> done = False; >> While[!done && (index[[v]] < Length[space[[v]]]), >> index[[v]]++; >> done = Apply[partialQ,{Solution[space,index,v]}]; >> ]; >> If [done, v++, index[[v--]]=0 ]; >> If [v > n, >> solution = Solution[space,index,n]; >> If [Apply[solutionQ,{solution}], >> If [SameQ[flag,All], >> AppendTo[all,solution], >> all = solution; v=0 >> ] >> ]; >> v-- >> ] >> ]; >> all >> ]; >> >> Solution = >> Compile[{{space, _Integer, 2}, {index, _Integer, 1}, {count, >> _Integer}}, >> Module[{i}, Table[space[[ i, index[[i]] ]], {i, count}] ]]; >> >> >> Note that the function is designed to work with integers. However, if >> your lists consists of rationals it is easy to convert them to >> integers. I am also going to assume that your list contains each >> number only once. This can be relaxed but at a price of efficiency >> (see below). >> >> Here is first a code that works for lists of integers: >> >> >> findsum[L_, m_] := >> DeleteCases[Module[{sp, L1 = Prepend[L, 0], l, k = Length[L] + 1}, >> sp = Table[L1, {k}]; >> partialQ = >> Compile[{{l, _Integer, 1}}, >> If[Length[l] == 1, True, >> Plus @@ l â?¤ m && Plus @@ l + (k - Length[l])*Max[L] â?¥ m && >> If[l[[-1]] > 0, (l[[-1]] > l[[-2]]), True]]]; >> solutionQ = Compile[{{l, _Integer, 1}}, Plus @@ l == m]; >> Backtrack[sp, partialQ, solutionQ, One]], 0] >> >> Let's try it on an example: >> >> In[5]:= >> L=Range[100]; >> >> In[6]:= >> findsum[L,110]//Timing >> >> Out[6]= >> {0.18 Second,{10,100}} >> >> To allow rational input we add a definition: >> >> >> findsum[L_, m_] /; Not[FreeQ[L, Rational]] := >> Module[{d}, d = LCM @@ Denominator[Append[L, m]]; findsum[d *L, >> d*m]/d] >> >> In[8]:= >> myrationals = {1/2, 1/3, 1/4, 1/8, 3/10, 12/79, 13/38}; >> >> In[9]:= >> m=3/4; >> >> In[10]:= >> findsum[myrationals,m] >> >> Out[10]= >> {1/4, 1/2} >> >> Note that I have not preserved the order in which these terms appear >> in your list. (It is easy to do so but I am not sure you need it so >> decided not to bother). >> >> Of course your two list version is now also available: >> >> In[11]:= >> findsum[myrationals,#]&/@{3/4,3/8} >> >> Out[11]= >> {{1/4, 1/2}, {1/8, 1/4}} >> >> Finally, if you want to allow lists with repeated entries you need to >> modify findsum. One way is: >> >> >> findsum[L_, m_] := >> DeleteCases[Module[{sp, L1 = Prepend[L, 0], l, k = Length[L] + 1}, >> sp = Table[L1, {k}]; >> partialQ = >> Compile[{{l, _Integer, 1}}, >> If[Length[l] == 1, True, >> Plus @@ l â?¤ m && Plus @@ l + (k - Length[l])*Max[L] â?¥ m && >> If[l[[-1]] > 0, >> If[Count[L, l[[-1]]] == >> 1, (l[[-1]] > l[[-2]]), (l[[-1]] >= l[[-2]])], >> True]]]; >> solutionQ = Compile[{{l, _Integer, 1}}, Plus @@ l == m]; >> Backtrack[sp, partialQ, solutionQ, One]], 0] >> >> >> For example: >> >> myrationals = {1/3, 1/2, 1/2}; >> >> In[14]:= >> findsum[myrationals,1] >> >> Out[14]= >> {1/2, 1/2} >> >> >> >> On Monday, February 25, 2002, at 07:31 AM, Mark Ganson wrote: >> >>> Hello, >>> >>> I need a function that will find the first subset of a list that will >>> sum up to a given value. >>> >>> For example, if I have a list of rationals: >>> >>> myrationals = {1/2, 1/3, 1/4, 1/8, 3/10, 12/79, 13/38} >>> >>> I would like a function that will return the first subset of >>> myrationals that sums up to a given parameter. >>> >>> We can call the function "findsum". It would work like so: >>> >>> In: findsum[myrationals, 3/4] >>> Out: {1/2, 1/4} >>> >>> It would be nice also, but not essential, to be able to use another >>> list as the second parameter and have the function return a list of >>> lists. >>> >>> Example: >>> >>> In: findsum[myrationals, {3/4, 3/8}] >>> Out: {{1/2, 1/4}, {1/4, 1/8}} >>> >>> I need something really fast and memory efficient because my lists >>> tend to be quite large (up to 100 elements). >>> >>> >>> Many thanks, >>> >>> Mark Ganson >>> >>> >>> >> >

**Re: need a function for sums of subsets**

**Re: Sound and CDs query. Probably an FAQ but I could not find it.**

**Re: need a function for sums of subsets**

**need a function for sums of subsets**