Re: need a function for sums of subsets
- To: mathgroup at smc.vnet.net
- Subject: [mg33018] Re: [mg33001] need a function for sums of subsets
- From: Andrzej Kozlowski <andrzej at tuins.ac.jp>
- Date: Tue, 26 Feb 2002 04:35:00 -0500 (EST)
- Sender: owner-wri-mathgroup at wolfram.com
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}
>
Andrzej Kozlowski
Toyama International University
JAPAN
http://platon.c.u-tokyo.ac.jp/andrzej/
>
>
> 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
>>
>>
>>
>