How to enumerate all possible binary associations?

Question

Suppose I have a list of symbols like:

{a,b,c,d}

I would like to enumerate all possible binary associations (combining symbols and/or sublists pairwise):

{{{a,b},c},d}
{{a,b},{c,d}}
{a,{b,{c,d}}}
{{a,{b,c}},d}
{a,{{b,c},d}}

There should be altogether 5 solutions for this example. My question is how can I enumerate all such associations for a generic list?

I have tried

ReplaceList[{a,b,c,d},{u___,v_,w_,x___}:>{u,{v,w},x}]

But this only works for the first layer.

Answer 1

I propose a more compact approach

f[list__] := Join @@ ReplaceList[{list}, {x__, y__} :> Tuples@{f[x], f[y]}]
f[x_] := {x};

f[a, b, c, d] // Column

{a,{b,{c,d}}}
{a,{{b,c},d}}
{{a,b},{c,d}}
{{a,{b,c}},d}
{{{a,b},c},d}

One can note that the length of this list is the Catalan number

$$ C_n = \frac{1}{1+n}{2n\choose n} $$

Length[f @@ ConstantArray[a, 6]]
CatalanNumber[6 - 1]
WolframAlpha["answer to life the universe and everything"]

42
42
42

Answer 2

I think one way is to do your ReplaceList repeatedly, until the result doesn't change any more.

FixedPoint[
 DeleteDuplicates[Flatten[
    Function[lst,
      If[# === {}, {lst}, #] &[
       ReplaceList[lst,
        {u___, v_, w_, x___} /;
          Nand[{u} === {}, {x} === {}] :>
         {u, {v, w}, x}]
       ]
      ] /@ #,
    1]] &,
 {Range[5]}
 ];

TreeForm /@ %

Answer 3

How about a recursive approach?

ClearAll[a, b, c, d, func];
set = {a, b, c, d};

counter = 0;
rules = {};
func[{x_}] := x;
func[list_] := Module[{r}, DeleteDuplicates@Flatten[func /@ 
    ReplaceList[list, {a___, x_, y_, b___} :> {a, {x, y} /. 
    rules /. {x, y} :> (r = RandomReal[]; PrependTo[rules, {x, y} -> r]; r), b}],
   1]];

temp = func@set;
Fold[ReplaceAll, temp, Reverse /@ rules]

  {
   {{{a, b}, c}, d},
   {{a, b}, {c, d}},
   {{a, {b, c}}, d},
   {a, {{b, c}, d}},
   {a, {b, {c, d}}}
   }

Update Made it faster. Random reals are generated to denote parental nodes. There is an infinitesimal chance that a set of random reals might interfere with generated node-identifiers.

Answer 4

In Mathematica 11, we don't have to write a solution ourselves.

M11 has Groupings

Groupings[{a1,...,an},k]

gives all possible groupings of a1,...,an taken k at a time.

So

Groupings[{a, b, c, d}, 2] gives

{{{{a, b}, c}, d}, {a, {{b, c}, d}}, {{a, {b, c}}, 
  d}, {a, {b, {c, d}}}, {{a, b}, {c, d}}}

easy life with M11 :)

Answer 5

I can't possibly compete with the beautiful solution provided by ybeltukov, but I had already started thinking about it, so here's what I came up with.

The first thing was to define a function to check whether a proposed partitioning has the correct properties:

twoQ[ll_List] := Length@ll == 2 && twoQ[ll[[1]]] && twoQ[ll[[2]]]
twoQ[ll_] := True;

Then, to find the partitioning:

t[{x_}] := {x}
t[ll_] := Flatten[Table[{l1, l2}, {j, 1, Length[ll] - 1},
     {l1, t@ll[[1 ;; j]]}, {l2, t@ll[[j + 1 ;; -1]]}], 2];

so that

t[{a,b,c,d}]
(* 
    {{a, {b, {c, d}}},
     {a, {{b, c}, d}},
     {{a, b}, {c, d}}, 
     {{a, {b, c}}, d}, 
     {{{a, b}, c}, d}} *)

 twoQ /@ %
 (* {True, True, True, True, True} *)