19
$\begingroup$

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.

$\endgroup$
1
  • $\begingroup$ 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? $\endgroup$
    – DavidC
    Nov 27, 2013 at 13:11

5 Answers 5

18
$\begingroup$

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

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

binary association tree plots

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

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.

$\endgroup$
2
  • $\begingroup$ @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. $\endgroup$ Nov 27, 2013 at 13:16
  • $\begingroup$ Sorry I used set = Range[5] for test, which caused the never stopping //.. You got my +1 :) $\endgroup$
    – Silvia
    Nov 27, 2013 at 13:23
4
$\begingroup$

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

$\endgroup$
1
$\begingroup$

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} *)
$\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.