Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2002
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2002

[Date Index] [Thread Index] [Author Index]

Search the Archive

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
>>>
>>>
>>>
>>
>



  • Prev by Date: Re: need a function for sums of subsets
  • Next by Date: Re: Sound and CDs query. Probably an FAQ but I could not find it.
  • Previous by thread: Re: need a function for sums of subsets
  • Next by thread: need a function for sums of subsets