Re: combinatorics problem
- To: mathgroup at smc.vnet.net
- Subject: [mg40101] Re: [mg40087] combinatorics problem
- From: Dr Bob <drbob at bigfoot.com>
- Date: Thu, 20 Mar 2003 03:34:10 -0500 (EST)
- References: <200303190823.DAA28940@smc.vnet.net>
- Reply-to: drbob at bigfoot.com
- Sender: owner-wri-mathgroup at wolfram.com
Here's a function I wrote another time which should help, although it
merges the sublists. You can either slice them up again or modify the
function so that it doesn't merge them.
Your other steps are very easy, after that.
<< DiscreteMath`Combinatorica`;
ClearAll[combinations];
combinations::usage = "combinations[list,n:{__Integer}] lists the \
combinations of list taken n at a time";
combinations[r_List, n_Integer, {}] := Which[n > Length@r, {}, n ==
Length@r, \
r, True, DiscreteMath`Combinatorica`KSubsets[r, n]];
combinations[r_List, n_Integer, e_?VectorQ] := Join[e, #] & /@ \
DiscreteMath`Combinatorica`KSubsets[Complement[r, e], n];
combinations[r_List, n_Integer, e : {__?VectorQ}] := Flatten[combinations[
r, n, #] & /@ e, 1];
combinations[r_List, {n_Integer}] := combinations[r, n, {}];
combinations[r_List, n : {__Integer}] := Which[Plus @@ n == Length@r,
Join[#, Complement[r, #]] & /@ combinations[r, Drop[
n, -1]], Plus @@ n > Length@r, {}, True, Fold[combinations[r, #2,
#1] &, {}, n]]
Bobby
On Wed, 19 Mar 2003 03:23:24 -0500 (EST), Szumiloski, John
<john_szumiloski at merck.com> wrote:
> Dear MathGroupers,
>
> (I use both v4.2 for WinNT 4 w/ 512MB RAM, and v4.0.1 for MacOS 8.6 w/
> 160
> MB RAM.)
>
> I am trying to write a function which takes a list 'listA' of n integers
> (perhaps nondistinct) and an arbitrary integer partition 'P' of n, and,
> for
> the list of all the ways to partition the elements of listA into sublists
> of
> the sizes given by P, sums each sublist for each instance and returns the
> number of times each distinct set of sums (where the order is not
> important)
> occurs. (Apologies for using 'partition' in two different ways here)
>
> This is complicated, so an example definitely helps. Let's break the
> problem up. Say the function prelimfunc returns a list of all the ways
> to
> partition the elements of listA into sublists of the sizes given by P:
>
> In[1]:= listA = {1,2,3,4,5} ; P = {2,2,1}; (* Note Length[listA] =
> Apply[Plus,P] *)
>
> In[2]:= pre1=prelimfunc[listA, P] Out[2]= { {{1,2},{3,4},{5}},
> {{1,2},{3,5},{4}}, {{1,2},{4,5},{3}}, {{1,3},{2,4},{5}},
> {{1,3},{2,5},{4}}, {{1,3},{4,5},{2}}, {{1,4},{2,3},{5}},
> {{1,4},{2,5},{3}}, {{1,4},{3,5},{2}}, {{1,5},{2,3},{4}},
> {{1,5},{2,4},{3}}, {{1,5},{3,4},{2}}, {{2,3},{4,5},{1}},
> {{2,4},{3,5},{1}}, {{2,5},{3,4},{1}} }
>
> Desired properties of prelimfunc:
> 1) The order of the returned list is not important; the example's order
> was
> just an artifact of my enumerating the result in my head.
> 2) The ordering of the sublists are not important. Thus,
> {{1,2},{3,4},{5}}
> would be considered the same list as {{3,4},{1,2},{5}}, so only one would
> appear in the result. 3) The ordering of the elements within each
> sublist are not important.
> Thus, {{1,2},{3,4},{5}} would be considered the same list as
> {{2,1},{3,4},{5}}, so only one would appear in the result. 4) Replicates
> of the elements of listA are considered distinct. This, if
> listA={1,2,3,1,5} (where there are two elements equal to 1), there would
> be
> two lists of {{1,3},{1,5},{2}} in the result, corresponding to the 6th
> and
> 12th list element in the above output. Since there are two "1"s in this
> listA, this result would not violate property (2) above, since the "1"s
> are
> considered distinct. Thus the result will always contain the same number
> of
> possible partitions of listA so long as listA has same length n and the
> integer partition of n remains the same.
>
> The next operation would be, for each element in this list, to sum up
> each
> sublist:
>
> In[3]:= pre2=Map[Apply[Plus, #]&, pre1, {2}]
> Out[3]= { {3, 7, 5}, {3, 8, 4}, {3, 9, 3}, {4, 6, 5}, {4, 7, 4}, {4, 9,
> 2}, {5, 5, 5}, {5, 7, 3}, {5, 8, 2}, {6, 5, 4}, {6, 6, 3}, {6, 7, 2}, {5,
> 9, 1}, {6, 8, 1}, {7, 7, 1} }
>
> Next, determine the distinct set of sums:
>
> In[4]:= pre3=Union[Map[Sort, pre2] ]
> Out[4]= { {1, 5, 9}, {1, 6, 8}, {1, 7, 7}, {2, 4, 9}, {2, 5, 8}, {2, 6,
> 7}, {3, 3, 9}, {3, 4, 8}, {3, 5, 7}, {3, 6, 6}, {4, 4, 7}, {4, 5, 6}, {5,
> 5, 5} }
>
> Next, for each of these sets, count how many times each appears in the
> previous result (order not being important):
>
> In[5]:= pre4=Map[Count[#, True]&, Outer[SameQ, pre3, Map[Sort, pre2], 1]
> ]
> Out[5]= {1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 2, 1}
>
> Last, return the unique sets of sums with the number of times each
> appears:
>
> In[6]:= Thread[List[pre3, pre4] ] (* for example *)
> Out[6]= { {{1, 5, 9}, 1}, {{1, 6, 8}, 1}, {{1, 7, 7}, 1}, {{2, 4, 9}, 1},
> {{2, 5, 8}, 1}, {{2, 6, 7}, 1}, {{3, 3, 9}, 1}, {{3, 4, 8},
> 1},
> {{3, 5, 7}, 2}, {{3, 6, 6}, 1}, {{4, 4, 7}, 1}, {{4, 5, 6},
> 2}, {{5, 5, 5}, 1} }
>
> So I want a function myfunc which would do this:
>
> In[7]:= myfunc[listA, P]
> Out[7]= { {{1, 5, 9}, 1}, {{1, 6, 8}, 1}, {{1, 7, 7}, 1}, {{2, 4, 9}, 1},
> {{2, 5, 8}, 1}, {{2, 6, 7}, 1}, {{3, 3, 9}, 1}, {{3, 4, 8},
> 1},
> {{3, 5, 7}, 2}, {{3, 6, 6}, 1}, {{4, 4, 7}, 1}, {{4, 5, 6},
> 2}, {{5, 5, 5}, 1} }
>
> Another example, with more multiplicities:
>
> In[8]:= myfunc[{1,1,2,2,3}, {2,2,1}]
> Out[8]= { {{1, 3, 5}, 4}, {{1, 4, 4}, 2}, {{2, 2, 5}, 2},
> {{2, 3, 4}, 5}, {{3, 3, 3}, 2} }
>
> I have figured out how to write a naive version of prelimfunc by 1)
> simply
> enumerating all permutations of listA, 2) pruning (if P has some repeated
> elements; accounts for property (2) above), 3) inserting braces in the
> appropriate places. So with the additional steps above given explicitly,
> in
> a sense I have solved my problem.
>
>
> ****However****, I would like a solution which does not have intermediate
> steps that consume memory (and time?) at an (supra-?)exponential rate. I
> am
> interested in using listA of 30-40 elements or maybe more (!).
>
> One approach could be to enumerate the distinct set of sums (e.g., pre3)
> first, then determine how many times each would appear. I have written
> this
> function which enumerates the possible sum sets, based loosely on the
> Partitions code in the Combinatorica package:
>
> (******** Begin code ********)
> NonZeroCompositions[totalsum_Integer /; totalsum <= 1, ___] := {};
> NonZeroCompositions[totalsum_Integer, ngroups_Integer /; ngroups < 1,
> ___]
> := {};
> NonZeroCompositions[totalsum_Integer, 1, ___ ] := {{totalsum}};
> NonZeroCompositions[totalsum_Integer, ngroups_Integer, ___] /; (ngroups >
> totalsum) := {};
> NonZeroCompositions[totalsum_Integer, ngroups_Integer] :=
> NonZeroCompositions[totalsum, ngroups] = NonZeroCompositions[totalsum,
> ngroups, 1];
> NonZeroCompositions[totalsum_Integer, ngroups_Integer, low_Integer] /;
> (low * ngroups > totalsum)
> := {};
> (* ...and the workhorse... *)
> NonZeroCompositions[totalsum_Integer, ngroups_Integer, low_Integer] :=
> Partition[Flatten[Table[Map[Append[{i}, #] &,
> NonZeroCompositions[totalsum -
> i, ngroups - 1, i]],
> {i, low, Floor[totalsum/ngroups]}
> ]
> ], ngroups];
> (******** End code ********)
>
> The argument totalsum refers to the sum of the elements of listA (so the
> sum
> over each set in the result is also this), and ngroups to the number of
> elements in the partition P. Thus to get the candidate sum sets for the
> example, we do
>
> In[8]:= sets=NonZeroCompositions[Apply[Plus, listA] (* = 15 *), Length[P]
> (*
> = 3 *) ]
> Out[8]= { {1, 1, 13}, {1, 2, 12}, {1, 3, 11}, {1, 4, 10}, {1, 5, 9}, {1,
> 6,
> 8}, {1, 7, 7}, {2, 2, 11}, {2, 3, 10}, {2, 4, 9}, {2, 5, 8}, {2,
> 6, 7}, {3, 3, 9}, {3, 4, 8}, {3, 5, 7}, {3, 6, 6}, {4, 4, 7}, {4, 5,
> 6}, {5, 5, 5} }
>
> Now some of these do not appear in pre3 (e.g., {1,1,13}); without loss of
> generality I would have my function not include such sum sets in the
> final
> result.
>
>
> Given 'listA', 'P', and now 'sets', I suspect I can Map 'sets' into a
> function of listA and P which counts the number of times each sum set
> would
> appear, **without** actually enumerating all the partitions, summing
> etc.,
> etc. I strongly suspect this can be done using Backtrack from the
> Combinatorica package. But this is now getting beyond my level of
> Mathematica competence.
>
> Any assistance would be most welcome; suggestions of course do not have
> to
> utilize my NonZeroCompositions function, although I suspect it would be
> useful. If I get more than one approach, I may summarize some
> performance
> benchmarks for the group.
>
> Thanks in advance for any insights.
>
> John
>
> --------------------------------------------------------------------------
>
>
> ----
> Notice: This e-mail message, together with any attachments, contains
> information of Merck & Co., Inc. (Whitehouse Station, New Jersey, USA)
> that may be confidential, proprietary copyrighted and/or legally
> privileged, and is intended solely for the use of the individual or
> entity named on this message. If you are not the intended recipient, and
> have received this message in error, please immediately return this by e-
> mail and then delete it.
>
> ==============================================================================
>
>
>
--
majort at cox-internet.com
Bobby R. Treat
- References:
- combinatorics problem
- From: "Szumiloski, John" <john_szumiloski@merck.com>
- combinatorics problem