18
$\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$
  • $\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 '13 at 13:11
17
$\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$
  • $\begingroup$ +1 Much-much-much faster than mine! $\endgroup$ – István Zachar Nov 27 '13 at 14:20
  • $\begingroup$ I am wondering if someone can device a non-rule based solution... $\endgroup$ – tchronis Nov 27 '13 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$ – Simon Woods Nov 27 '13 at 14:54
  • $\begingroup$ @ybeltukov Great solution. Thank you very much! $\endgroup$ – Everett You Nov 27 '13 at 20:35
  • 2
    $\begingroup$ WolframAlpha["Don't panic"] $\endgroup$ – Dr. belisarius Nov 27 '13 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$
  • 1
    $\begingroup$ Hey Silvia! Long time no see :) $\endgroup$ – Yves Klett Nov 27 '13 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 '13 at 12:42
  • $\begingroup$ Welcome baaaack - hope you are doing fine! $\endgroup$ – Yves Klett Nov 27 '13 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 '13 at 12:46
  • 1
    $\begingroup$ @Silvia Welcome back! Raspberry: youtube.com/watch?v=6dmhF1rqaZk $\endgroup$ – Dr. belisarius Nov 27 '13 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$
  • $\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$ – István Zachar Nov 27 '13 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 '13 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.