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

**Re: combinatorics problem**

**Re: Finding solutions to differential eqns**

**Re: combinatorics problem**

**Re: combinatorics problem**