How to generate all possible orderless partitions of a list according to another list?

A solution using Repeated, ReplaceList, and the Orderless attribute.

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

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

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

This proves to be an order of magnitude faster than BoLe's code:

SeedRandom[1]
p = RandomInteger[{1, 3}, 6];
a = Range @ Tr @ p;

Flatten[split[a, p]] /. sol -> List  // Length // RepeatedTiming

part[a, p]                           // Length // RepeatedTiming

{0.7517, 45360}

{0.0766, 45360}

---

Relation to Permutations

Note: I completely overlooked Simon Woods's answer before starting on this section. Nevertheless after reading and digesting his answer I believe I have something unique to offer.

I was reminded of a different approach to this problem using Permutations thanks to an apparently coincidental vote on an old answer of mine:

• How can I get every distinct size-n combination of a list?

Consider that there is a one-to-one mapping between your target list and this:

Permutations[{1, 1, 2, 2, 3}]

{{1, 1, 2, 2, 3}, {1, 1, 2, 3, 2}, . . ., {3, 2, 1, 2, 1}, {3, 2, 2, 1, 1}}

Permutations by itself is very efficient. It is nearly two orders of magnitude better than part defined above, and its output takes a fraction of the memory:

maskFn = Permutations @* Flatten @* MapIndexed[Table[#2, {#}] &];

a = Range @ 12;
p = {2, 3, 1, 3, 2, 1};

part[a, p] // ByteCount // RepeatedTiming
maskFn[p]  // ByteCount // RepeatedTiming

{6.49, 2075673680}

{0.0984, 319334552}

If you can write whatever operations follow this in terms of the permutation masks rather than the partitions there is clearly the potential for a major optimization.

Now, after reading Simon's answer and being inspired by it, I offer the following solution.

We can use Ordering as Simon did to convert the permutations, and then split the result using a slight modification of my dynP from:

• Partitioning with varying partition size

This provides my second proposal:

maskFn = Permutations @* Flatten @* MapIndexed[Table[#2, {#}] &];

dynP2[m_, p_] := 
 MapThread[
   m[[All, # ;; #2]] &,
   {{0} ~Join~ Most@# + 1, #} & @ Accumulate @ p
 ]\[Transpose]

part2[a_List, p_List] := dynP2[a[[ Ordering @ # ]] & /@ maskFn[p], p]

Comparing (in v10.1) the performance of both of my functions to Simon's parts:

a = Alphabet[] ~Take~ 11;
p = {2, 1, 3, 1, 2, 2};

RepeatedTiming @ Length @ #[a, p] & /@ {part, part2, parts}

{{1.452, 831600}, {2.052, 831600}, {2.30, 831600}}

And again but with a packable a list:

a = Range @ 11;
p = {2, 1, 3, 1, 2, 2};

RepeatedTiming @ Length @ #[a, p] & /@ {part, part2, parts}

{{1.45, 831600}, {1.59, 831600}, {1.43, 831600}}

It seems to me that part is still the best general function, but Simon's code is slightly faster in the case of a packed/packable input list.

Permutations treats repeated elements as identical, so you can get a flattened version of the desired result with something like

Ordering /@ Permutations[{1, 1, 2, 2, 3}]

(* {{1, 2, 3, 4, 5}, {1, 2, 3, 5, 4}, {1, 2, 4, 5, 3} ... {4, 5, 2, 3, 1} *)

A simple solution based on this idea:

parts[list_, p_] := Module[{q},
  q = Flatten@MapThread[ConstantArray, {Range@Length@p, p}];
  Internal`PartitionRagged[list[[Ordering[#]]], p] & /@ Permutations[q]]

Unforunately Internal`PartitionRagged is rather slow; it is faster (though less elegant) to create a function which does the reshaping:

parts[list_, p_] := Module[{q, f, slot},
  q = Flatten@MapThread[ConstantArray, {Range@Length@p, p}];
  f = Function @@ {Internal`PartitionRagged[Array[slot, Length@list], p]} /. slot -> Slot;
  f @@@ (list[[Ordering[#]]] & /@ Permutations[q])]

This is comparable to Mr Wizard's in terms of speed.

It's far from pretty, using pattern matching (OrderlessPatternSequence):

ReplaceList[#1,
  Module[{names = Unique[] & /@ #1, partitions},
    partitions = Internal`PartitionRagged[names, #2]; 
    Activate[{OrderlessPatternSequence @@ (Pattern[#, _] & /@ names)} /; 
       Evaluate[And @@ (Inactive@OrderedQ /@ partitions)] :> 
      Evaluate@partitions]]] &[Range@5, {2, 2, 1}]

The pattern we construct for the case of these arguments is:

{OrderlessPatternSequence[$3_, $4_, $5_, $6_, $7_]} /; 
 OrderedQ[{$3, $4}] && OrderedQ[{$5, $6}] && OrderedQ[{$7}] :> 
 {{$3, $4}, {$5, $6}, {$7}}