How to enumerate all possible binary associations?

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.

• Kindly explain what you mean by a binary association. (I'm trying to reconcile your question with what I've found online at en.wikipedia.org/wiki/Class_diagram) Does Silvia's output satisfy your idea of binary association? Nov 27, 2013 at 13:11

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

• +1 Much-much-much faster than mine! Nov 27, 2013 at 14:20
• I am wondering if someone can device a non-rule based solution... Nov 27, 2013 at 14:50
• +1 Very nice! I was looking along similar lines but trying to use Thread on the RHS of the rule. Tuples is inspired. Nov 27, 2013 at 14:54
• @ybeltukov Great solution. Thank you very much! Nov 27, 2013 at 20:35
• WolframAlpha["Don't panic"] Nov 27, 2013 at 21:01

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 /@ %


• Hey Silvia! Long time no see :) Nov 27, 2013 at 12:38
• @YvesKlett Hi! Had a tough year without computers and just got my MMA home edition not long ago :) Nov 27, 2013 at 12:42
• Welcome baaaack - hope you are doing fine! Nov 27, 2013 at 12:42
• @YvesKlett Thanks a lot :) You make me feel back to home~ Everything is great now. And I even got myself a Raspberry Pi :D Nov 27, 2013 at 12:46
• @Silvia Welcome back! Raspberry: youtube.com/watch?v=6dmhF1rqaZk Nov 27, 2013 at 13:42

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.

• @Silvia Had to extend it to remove some redundancy. Please check. It is pretty slow for sets longer than 8 elements... Yours is definitely faster. Nov 27, 2013 at 13:16
• Sorry I used set = Range[5] for test, which caused the never stopping //.. You got my +1 :) Nov 27, 2013 at 13:23

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 :)

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