Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2003
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2003

[Date Index] [Thread Index] [Author Index]

Search the Archive

combinatorics problem

  • To: mathgroup at smc.vnet.net
  • Subject: [mg40087] combinatorics problem
  • From: "Szumiloski, John" <john_szumiloski at merck.com>
  • Date: Wed, 19 Mar 2003 03:23:24 -0500 (EST)
  • Sender: owner-wri-mathgroup at wolfram.com

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.

==============================================================================



  • Prev by Date: RE: a challenge/problem.
  • Next by Date: Re: RE: Increase in efficiency with Module
  • Previous by thread: Trouble with an iterative function
  • Next by thread: Re: combinatorics problem