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