2

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]]]]
Subho
  • 1,534
  • 1
  • 8
  • 18
  • Is DeleteDuplicatesBy[yourResult, Sort] what you are looking for? – MarcoB May 14 '18 at 01:33
  • @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. – Subho May 14 '18 at 01:49
  • @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. – Subho May 14 '18 at 01:51

2 Answers2

3

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

Union[Sort /@ list]

removes the duplicates.

bill s
  • 68,936
  • 4
  • 101
  • 191
  • 2
    DeleteDuplicatesBy[list, Sort] would also achieve your same result; it avoids changing the sorting of the overall list, in case that is not desirable. – MarcoB May 14 '18 at 01:32
1

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}}}

Subho
  • 1,534
  • 1
  • 8
  • 18