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

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

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

```

• Prev by Date: Re: combinatorics problem
• Next by Date: Re: Finding solutions to differential eqns
• Previous by thread: Re: combinatorics problem
• Next by thread: Re: combinatorics problem