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

Re: combinatorics problem

  • To: mathgroup at smc.vnet.net
  • Subject: [mg40104] Re: [mg40087] combinatorics problem
  • From: Dr Bob <drbob at bigfoot.com>
  • Date: Thu, 20 Mar 2003 03:34:52 -0500 (EST)
  • References: <200303190823.DAA28940@smc.vnet.net>
  • Reply-to: drbob at bigfoot.com
  • Sender: owner-wri-mathgroup at wolfram.com

This gets you a step or two farther:

<< 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]]
ClearAll@splitter
splitter[n : {__Integer}] := Range @@@ Transpose@{Drop[FoldList[Plus, 1, 
p], -1], Rest@FoldList[Plus, 0, p]}
combo[a_List, n : {__Integer}] :=
   Transpose[combinations[a, n][[All, #]] & /@ splitter@n]
listA = {1, 2, 3, 4, 5};
p = {2, 2, 1};
combo[listA, p]

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



  • Prev by Date: Re: combinatorics problem
  • Next by Date: Re: combinatorics problem
  • Previous by thread: Re: combinatorics problem
  • Next by thread: Re: combinatorics problem