2
$\begingroup$

This is a slight variation of: How to generate all possible orderless partitions of a list according to another list?

Consider each set following a partition a "box" and each element a "ball".

What are all the possible partitions where the balls are distinct but boxes are identical(i.e. no ordering among the boxes) and there is no ordering of the balls in a box?

(Note that @Mr. Wizard's answer covered the case where the balls inside any given box was orderless. I am going a step further and demanding the boxes to be treated identical.)

My attempt:

I assume that the partition sizes are non-decreasing(eg {1,2,2) for the set{1,2,3,4,5}) so that I can use OrderedQ to filter the identical(canonical) configurations.

part[a_List, p_List] := Module[{f, sym}, Attributes[f] = Orderless;
  sym = Unique["x", Temporary] & /@ p;
  ReplaceList[f @@ a, 
   With[{patt = 
       MapThread[Pattern[#1, Repeated[_, {#2}]] &, {sym, p}]}, (f @@ 
        patt) /; OrderedQ[patt] == 0] -> List /@ sym]]

or

part[a_List, p_List] := Module[{f, sym}, Attributes[f] = Orderless;
  sym = Unique["x", Temporary] & /@ p;
  ReplaceList[f @@ a, , 
   f @@ (patt : 
        MapThread[
         Pattern[#1, Repeated[_, {#2}]] &, {sym, p}]) /; (OrderedQ[
        patt] == 0) :> List /@ sym]]

Now, if one tries to evaluate:

part[{1, 2, 3, 4, 5}, {1, 2, 2}]

duplicates in :

{{{1}, {2, 3}, {4, 5}}, {{1}, {2, 4}, {3, 5}}, {{1}, {2, 5}, {3, 
   4}}, {{1}, {3, 4}, {2, 5}}, {{1}, {3, 5}, {2, 4}}, {{1}, {4, 
   5}, {2, 3}}, {{2}, {1, 3}, {4, 5}}, {{2}, {1, 4}, {3, 
   5}}, {{2}, {1, 5}, {3, 4}}, {{2}, {3, 4}, {1, 5}}, {{2}, {3, 
   5}, {1, 4}}, {{2}, {4, 5}, {1, 3}}, {{3}, {1, 2}, {4, 
   5}}, {{3}, {1, 4}, {2, 5}}, {{3}, {1, 5}, {2, 4}}, {{3}, {2, 
   4}, {1, 5}}, {{3}, {2, 5}, {1, 4}}, {{3}, {4, 5}, {1, 
   2}}, {{4}, {1, 2}, {3, 5}}, {{4}, {1, 3}, {2, 5}}, {{4}, {1, 
   5}, {2, 3}}, {{4}, {2, 3}, {1, 5}}, {{4}, {2, 5}, {1, 
   3}}, {{4}, {3, 5}, {1, 2}}, {{5}, {1, 2}, {3, 4}}, {{5}, {1, 
   3}, {2, 4}}, {{5}, {1, 4}, {2, 3}}, {{5}, {2, 3}, {1, 
   4}}, {{5}, {2, 4}, {1, 3}}, {{5}, {3, 4}, {1, 2}}}

like: {{1}, {2, 3}, {4, 5}} and {{1}, {4, 5}, {2, 3}} should not appear anymore.

But, none of them work. Help will be appreciated.

Edit 1:

This is another attempt I made, which returns the same answer. OrderedQ doesn't seem to work:

part[a_List, p_List] := Module[{f, sym}, Attributes[f] = Orderless;
  sym = Unique["x", Temporary] & /@ p;
  ReplaceList[f @@ a, 
   With[{patt = 
      MapThread[Pattern[#1, Repeated[_, {#2}]] &, {sym, p}]}, 
    Rule[Condition[f @@ patt, OrderedQ[List /@ sym] == True], 
     List /@ sym]]]]
$\endgroup$
  • $\begingroup$ Is DeleteDuplicatesBy[yourResult, Sort] what you are looking for? $\endgroup$ – MarcoB May 14 '18 at 1:33
  • $\begingroup$ @MarcoB No. I don't want to use DeleteDuplicatesBy as it will probably be inefficient for a large list. I want to instead use OrderedQ or the likes as I have mentioned in my post. $\endgroup$ – Subho May 14 '18 at 1:49
  • $\begingroup$ @MarcoB Can you just find the bug in my existing code? This is just a slight variation of Mr. Wizard's referenced answer from a long time back. $\endgroup$ – Subho May 14 '18 at 1:51
3
$\begingroup$

Say the output of your part function is called "list". Then

Union[Sort /@ list]

removes the duplicates.

$\endgroup$
  • 2
    $\begingroup$ DeleteDuplicatesBy[list, Sort] would also achieve your same result; it avoids changing the sorting of the overall list, in case that is not desirable. $\endgroup$ – MarcoB May 14 '18 at 1:32
1
$\begingroup$

This works:

OrderlessPartition[set_List, part_List] := 
 Module[{f, part2, list}, Attributes[f] = Orderless;
  part2 = Sort@part;
  list = Unique["x", Temporary] & /@ part2; 
  ReplaceList[f @@ set, 
   With[{list1 = list, list2 = List /@ list}, 
    f @@ (MapThread[
         Pattern[#1, Repeated[_, {#2}]] &, {list1, part2}]) /; 
      OrderedQ[list2] -> List /@ list1]]]

e.g.

OrderlessPartition[Range[6], {1, 2, 3}]

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

$\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.