6
$\begingroup$

I have a problem that feels like it should be simple but I'm just drawing a blank on. I've got a set of integers, e.g.

ogSet = PadRight[IntegerPartitions[20][[400]], 15]

{6, 4, 3, 3, 2, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0}

and a set of bins, e.g.,

bins = {{1, 2, 3, 4, 5}, {6, 7, 8, 9}, {10, 11}, {12, 13, 14}, {15}};

and I want to find the number of unique ways I can split these integers over the bins.

That is, I basically want to calculate this

testPerms = Permutations[ogSet][[;; 100]];
Table[
  Map[Sort@p[[#]] &, bins],
  {p, testPerms}
  ] // DeleteDuplicates

{
 {{2, 3, 3, 4, 6}, {0, 0, 1, 1}, {0, 0}, {0, 0, 0}, {0}},
 {{2, 3, 3, 4, 6}, {0, 0, 0, 1}, {0, 1}, {0, 0, 0}, {0}},
 {{2, 3, 3, 4, 6}, {0, 0, 0, 1}, {0, 0}, {0, 0, 1}, {0}},
 {{2, 3, 3, 4, 6}, {0, 0, 0, 1}, {0, 0}, {0, 0, 0}, {1}},
 {{2, 3, 3, 4, 6}, {0, 0, 0, 0}, {1, 1}, {0, 0, 0}, {0}},
 {{2, 3, 3, 4, 6}, {0, 0, 0, 0}, {0, 1}, {0, 0, 1}, {0}},
 {{2, 3, 3, 4, 6}, {0, 0, 0, 0}, {0, 1}, {0, 0, 0}, {1}},
 {{2, 3, 3, 4, 6}, {0, 0, 0, 0}, {0, 0}, {0, 1, 1}, {0}},
 {{2, 3, 3, 4, 6}, {0, 0, 0, 0}, {0, 0}, {0, 0, 1}, {1}},
 {{1, 3, 3, 4, 6}, {0, 0, 1, 2}, {0, 0}, {0, 0, 0}, {0}},
 {{1, 3, 3, 4, 6}, {0, 0, 0, 2}, {0, 1}, {0, 0, 0}, {0}},
 {{1, 3, 3, 4, 6}, {0, 0, 0, 2}, {0, 0}, {0, 0, 1}, {0}},
 {{1, 3, 3, 4, 6}, {0, 0, 0, 2}, {0, 0}, {0, 0, 0}, {1}},
 {{1, 3, 3, 4, 6}, {0, 0, 0, 1}, {0, 2}, {0, 0, 0}, {0}},
 {{1, 3, 3, 4, 6}, {0, 0, 0, 1}, {0, 0}, {0, 0, 2}, {0}},
 {{1, 3, 3, 4, 6}, {0, 0, 0, 1}, {0, 0}, {0, 0, 0}, {2}}
 }

but obviously as this number of terms gets larger, it becomes unfeasible to generate and test every permutation.

I'm sure there's a way to do this by mapping the ogSet to a set of character classes like

ogClasses = Counts[ogSet]

<|6 -> 1, 4 -> 1, 3 -> 2, 2 -> 1, 1 -> 2, 0 -> 8|>

and then doing some kind of intersection of those character classes with the bins, but I'm blanking on how to do this efficiently

$\endgroup$
4
  • $\begingroup$ In your solution example, are these combinations complete, or there are more? For instance, can 6 go to the last (15th) bin? $\endgroup$ – yarchik Mar 31 at 21:37
  • $\begingroup$ All possible permutations are allowed. I just didn't want to put too many out there in the name of keeping the wall of text small. $\endgroup$ – b3m2a1 Mar 31 at 21:39
  • $\begingroup$ Are equal-length bins considered distinct? For example, if I had two 1-element bins, would {... {1}, {0}} and {... {0}, {1}} be considered different configurations? $\endgroup$ – thorimur Mar 31 at 23:39
  • 1
    $\begingroup$ @thorimur yeah for my purposes each bin has an associated tag $\endgroup$ – b3m2a1 Mar 31 at 23:59
2
$\begingroup$

Here is a solution, but I'm sure someone smarter can do better. I'm gonna make use of the fact that it's easy to distribute one bag of balls over N bins, so we can reduce the original list to its set of unique classes and recursively refine.

For a single set of numEls balls split over our bins, we'll do things a little clumsily by taking all the permutations of the integer partitions, the saving grace of which is that the number of elements in the partition is restricted to the number of bins we have

getSplits[numEls_, binSizes_] :=
 Block[
  {
   parts = 
    PadRight[#, Length[binSizes]] & /@ 
     IntegerPartitions[numEls, Length[binSizes]],
   perms,
   binChanges,
   sel
   },
  Join[##] & @@@
   Transpose@
    Table[
     perms = Permutations[p];
     binChanges = ConstantArray[binSizes, Length[perms]] - perms;
     sel = Min[#] >= 0 & /@ binChanges;
     {
      Pick[perms, sel],
      Pick[binChanges, sel]
      },
     {p, parts}
     ]
  ]

You'll notice we're also tracking how the bins change once we take into account each partition/permutation, which will allow us to apply this recursively over each bag.

The trick here will be to build a tree that tracks where things were added and how much is left over

ClearAll[buildSplitTree, buildSplitSubtree];
buildSplitTree[counts_, binSizes_, binIdx_ : None] :=
  Block[
   {
    splits,
    binSel
    },
   If[Length[counts] > 1,
    splits = getSplits[counts[[1]], binSizes];
    Association@
     MapThread[
      # -> buildSplitSubtree[# > 0 & /@ #2, #2, counts, binIdx] &,
      splits
      ],
    (* 
    at this point we only have one element in 'counts' left, 
    so there's only one way to distribute these remaining elements
    *)
    {binSizes}
    ]
   ];
buildSplitSubtree[binSel_, binSizes_, counts_, binIdx_ : None] :=
  Block[
   {
    binInds =
     Pick[
      If[binIdx === None, Range[Length@binSizes], binIdx],
      binSel
      ]
    },
   {
    binInds,
    buildSplitTree[counts[[2 ;;]], Pick[binSizes, binSel], binInds]
    }
   ];

This will build a tree that tells us where/how to build each element of the desired output, but now we need to reduce this tree to a proper output

ClearAll[reduceSplitTree, sowReducedSoln];
reduceSplitTree[cur_, values_, idx_, splitTree_] :=
  Block[{c},
   KeyValueMap[
    Function[
     c = cur;
     MapThread[
      If[#2 > 0, AppendTo[c[[#]], {values[[1]], #2}]] &,
      {idx, #}
      ];
     If[AssociationQ[#2[[2]]],
      reduceSplitTree[c, values[[2 ;;]], #2[[1]], #2[[2]]],
      sowReducedSoln[c, values[[2 ;;]], #2[[1]], #2[[2]]] 
      ]
     ],
    splitTree
    ]
   ];
sowReducedSoln[cur_, values_, idx_, specs_] :=
  Block[{c},
   Do[
    c = cur;
    MapThread[
     If[#2 > 0,
       AppendTo[c[[#]], {values[[1]], #2}]
       ] &,
     {idx, s}
     ];
    Sow[c],
    {s, specs}
    ]
   ];
reduceSplitTree[splitTree_Association, values_] :=
 Reap[
   With[{nbins = Length[Keys[splitTree][[1]]]},
    reduceSplitTree[
     ConstantArray[{}, nbins],
     values,
     Range[nbins],
     splitTree
     ]
    ]
   ][[2, 1]]

Finally we can package this workflow up (along with the previous one for testing)

treeSplitStuff[ogSet_, bins_] :=
 
 Block[{classes = Counts[ogSet], binSizes, splits},
  binSizes = Length /@ bins;
  splits = buildSplitTree[Values@classes, binSizes];
  reduceSplitTree[splits, Keys@classes]
  ]

naiveSplitStuff[ogSet_, bins_] :=
 Block[
  {testPerms = Permutations[ogSet]},
  Table[
    Map[Sort@p[[#]] &, bins],
    {p, testPerms}
    ] // DeleteDuplicates
  ]

This doesn't return the exact output I set out for, but this output is workable for me. And now we see that...for small dimensions all this work is actually slower than the naive approach

smallOGSet = PadRight[IntegerPartitions[10][[4]], 10]

{8, 1, 1, 0, 0, 0, 0, 0, 0, 0}

smallBins = TakeList[Range[10], IntegerPartitions[10][[34]]]

{{1, 2, 3}, {4, 5}, {6, 7}, {8}, {9}, {10}}

RepeatedTiming[
 solns = treeSplitStuff[smallOGSet, smallBins];
 ]

{0.0039, Null}

RepeatedTiming[
 naiveSolns = naiveSplitStuff[smallOGSet, smallBins];
 ]

{0.0028, Null}

sortSolns = Sort[Map[Sort] /@ solns];
testSolns = Sort[Map[Tally] /@ naiveSolns];
sortSolns == testSolns

True

Where sortSolns looks like

sortSolns[[;; 5]]

{
 {{{0, 3}}, {{0, 2}}, {{0, 2}}, {{1, 1}}, {{1, 1}}, {{8, 1}}},
 {{{0, 3}}, {{0, 2}}, {{0, 2}}, {{1, 1}}, {{8, 1}}, {{1, 1}}},
 {{{0, 3}}, {{0, 2}}, {{0, 2}}, {{8, 1}}, {{1, 1}}, {{1, 1}}},
 {{{0, 3}}, {{0, 2}}, {{1, 2}}, {{0, 1}}, {{0, 1}}, {{8, 1}}},
 {{{0, 3}}, {{0, 2}}, {{1, 2}}, {{0, 1}}, {{8, 1}}, {{0, 1}}}
 }

which is basically a tally of how many of each class are in each bin

This pays off nicely at higher dimensions, though

ogSet = PadRight[IntegerPartitions[20][[400]], 15];
bins = {{1, 2, 3, 4, 5}, {6, 7, 8, 9}, {10, 11}, {12, 13, 14}, {15}};

AbsoluteTiming[
 solns = treeSplitStuff[ogSet, bins];
 ]

{0.572987, Null}

AbsoluteTiming[
 naiveSolns = naiveSplitStuff[ogSet, bins];
 ]

{115.691, Null}

sortSolns = Sort[Map[Sort] /@ solns];
testSolns = Sort[Map[Tally] /@ naiveSolns];
sortSolns == testSolns

True

But I'm still sure there's a faster/better/more elegant approach out there

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.