Re: combinatorics problem
- To: mathgroup at smc.vnet.net
- Subject: [mg40093] Re: combinatorics problem
- From: Paul Abbott <paul at physics.uwa.edu.au>
- Date: Thu, 20 Mar 2003 03:32:52 -0500 (EST)
- Organization: The University of Western Australia
- References: <b59a1e$sb3$1@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
In article <b59a1e$sb3$1 at smc.vnet.net>,
"Szumiloski, John" <john_szumiloski at merck.com> wrote:
> 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}} }
The new Combinatorica package, bundled with 4.2 contains a number of
improvements. For more information see
http://www.cs.uiowa.edu/~sriram/Combinatorica/
(You could also email the authors, Sriram Pemmaraju and Steven Skiena).
KSetPartitions goes some way to doing what you want (see below).
> 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} }
Here is such a function (it still uses pruning so can be made more
efficient):
<<DiscreteMath`
myfunc[l_, p_] :=
Module[{pre2, pre3, pre4},
pre2 = Sort /@ Map[Tr, Select[KSetPartitions[l, Length[p]],
Sort[Length /@ #] == Sort[p] &], {2}];
pre3 = Union[pre2];
pre4 = Count[pre2, #] & /@ pre3;
Thread[{pre3, pre4}]
]
Cheers,
Paul
> 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.
>
> ==============================================================================
--
Paul Abbott Phone: +61 8 9380 2734
School of Physics, M013 Fax: +61 8 9380 1014
The University of Western Australia (CRICOS Provider No 00126G)
35 Stirling Highway
Crawley WA 6009 mailto:paul at physics.uwa.edu.au
AUSTRALIA http://physics.uwa.edu.au/~paul