Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
    
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? –  David Carraher Nov 27 '13 at 13:11

4 Answers 4

up vote 12 down vote accepted

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
share|improve this answer
    
+1 Much faster than mine! –  Silvia Nov 27 '13 at 14:18
    
+1 Much-much-much faster than mine! –  István Zachar Nov 27 '13 at 14:20
    
I am wondering if someone can device a non-rule based solution... –  tchronis Nov 27 '13 at 14:50
1  
+1 Very nice! I was looking along similar lines but trying to use Thread on the RHS of the rule. Tuples is inspired. –  Simon Woods Nov 27 '13 at 14:54
1  
WolframAlpha["Don't panic"] –  belisarius Nov 27 '13 at 21:01

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.

share|improve this answer
    
@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. –  István Zachar Nov 27 '13 at 13:16
    
Sorry I used set = Range[5] for test, which caused the never stopping //.. You got my +1 :) –  Silvia Nov 27 '13 at 13:23

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

share|improve this answer
1  
Hey Silvia! Long time no see :) –  Yves Klett Nov 27 '13 at 12:38
    
@YvesKlett Hi! Had a tough year without computers and just got my MMA home edition not long ago :) –  Silvia Nov 27 '13 at 12:42
    
Welcome baaaack - hope you are doing fine! –  Yves Klett Nov 27 '13 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 –  Silvia Nov 27 '13 at 12:46
1  
@Silvia Welcome back! Raspberry: youtube.com/watch?v=6dmhF1rqaZk –  belisarius Nov 27 '13 at 13:42

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} *)
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.