7
$\begingroup$

I want to generate the following Table which shows the distribution of 3 balls in 3 cells. But so far I have had no luck using Permutations, Tuples, or even IntegerPartitions.

What is the shortest piece of Mathematica that will generate the following table

Output can be in the following form for each item in the table: {{a,b,c},{},{}} for {abc|-|-} and {{},{a,b},{c}} for {-|ab|c}

Edit: Solution based on Daniel Huber's accepted solution. Do let me know if I can simplify this further. It is a simple Mapper function that maps each tuple whose index corresponds to the ball letter (a,b, or c) and the element itself corresponds to the cell in which the ball lies (eg. tuple {1,2,2} maps to{{a},{b,c},{}}). Then we simply find all such tuples and translate them. All such tuples are Tuples[{1,2,3},3].

Mapper[i_List] := Module[{t = {{}, {}, {}}},
   Map[AppendTo[t[[i[[#]]]], {a, b, c}[[#]]] &, Range[3]]; t];
Multicolumn[Map[Mapper, Tuples[{1, 2, 3}, 3]], 3]

Output:

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

$\endgroup$
2
  • $\begingroup$ Welcome to Mathematica.SE! I hope you will become a regular contributor. To get started, 1) take the introductory tour now, 2) when you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge, 3) remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign, and 4) give help too, by answering questions in your areas of expertise. $\endgroup$
    – bbgodfrey
    Oct 14 at 10:51
  • 1
    $\begingroup$ Similar question (but balls are not uniquely identified): mathematica.stackexchange.com/questions/209618/…. $\endgroup$
    – JimB
    Oct 14 at 17:21
5
$\begingroup$

Make a loop over i1,i2,i3 and put "a" in cell i1, "b" in cell i2 and "c" in i3.

Towards this aim we first define a function that puts "a,b,c" in cells i1,i2,i3:

fun[i1_, i2_, i3_] := Module[{t = {{}, {}, {}}},
  t[[i1]] = Join[t[[i1]], {a}]; t[[i2]] = Join[t[[i2]], {b}]; 
  t[[i3]] = Join[t[[i3]], {c}]; t]

Now it is easy to create the data:

dat = Table[fun[i1, i2, i3], {i1, 3}, {i2, 3}, {i3, 3}];

Finally we may display the data as a Table:

Grid[Flatten[dat, 1], Frame -> All]

enter image description here

$\endgroup$
10
$\begingroup$

We can use the function partition from this answer by Mr.Wizard to get all partitions of the input list:

partition[{x_}] := {{{x}}}
partition[{r__, x_}] := 
 Join @@ (ReplaceList[#, {{b___, {S__}, a___} :> {b, {S, x}, 
         a}, {S__} :> {S, {x}}}] & /@ partition[{r}])

For each partition, use PadRight to add {} to get the desired number of bins and take Permutations:

ClearAll[binLists]
binLists[l_List, nbins_Integer] := 
 Module[{p = Join @@ (Permutations[PadRight[#, nbins, {{}}]] & /@ partition[l])}, 
  If[nbins >= Length@l, p, Select[Sort[l] == Union @@ # &]@p]]

binLists[l_List] := binLists[l, Length@l]


binLists[{a, b, c}] // Multicolumn[#, 3] &

enter image description here

Multicolumn[
 ReplaceAll[{{} -> "-", p : {(a | b | c) ..} :> StringRiffle[p, ""]}]@
  binLists[{a, b, c}], 
 3]

enter image description here

Use 2 bins:

Multicolumn[
 ReplaceAll[{{} -> "-", p : {(a | b | c) ..} :> StringRiffle[p, ""]}]@
  binLists[{a, b, c}, 2], 
 4]

enter image description here

Use 4 bins:

Multicolumn[
 ReplaceAll[{{} -> "-", p : {(a | b | c) ..} :> StringRiffle[p, ""]}]@
  binLists[{a, b, c}, 4], 
 8]

enter image description here

Use input list {a,b,c,d}:

Multicolumn[
 ReplaceAll[{{} -> "-", p : {(a | b | c | d) ..} :> StringRiffle[p, ""]}]@
  binLists[{a, b, c, d}], 
 10]

enter image description here

Place {a,b,c,d} into 3 bins:

Multicolumn[
 ReplaceAll[{{} -> "-", p : {(a | b | c | d) ..} :> StringRiffle[p, ""]}]@
  binLists[{a, b, c, d}, 3], 
 10]

enter image description here

Place {a,b,c,d} into 2 bins:

Multicolumn[
 ReplaceAll[{{} -> "-", p : {(a | b | c | d) ..} :> StringRiffle[p, ""]}]@
  binLists[{a, b, c, d}, 2], 
 10]

enter image description here

Place {a,b,c,d,e} into 2 bins:

Multicolumn[
 ReplaceAll[{{} -> "-", p : {(a | b | c | d | e) ..} :> StringRiffle[p, ""]}]@
  binLists[{a, b, c, d, e}, 2], 
 10]

enter image description here

$\endgroup$
5
$\begingroup$
partitionQ[l_List][p__List] := DuplicateFreeQ[Flatten@p] && Sort[l] == Union @@ p;

kPartitions[l_List, nbins_Integer] := Select[partitionQ[l]]@Tuples[Subsets @ l, {nbins}]

partitions = kPartitions[{a, b, c}, 3];

Multicolumn[partitions, 3]

enter image description here

Multicolumn[
  ReplaceAll[{{} -> "-", p : {(a | b | c) ..} :> StringRiffle[p, ""]}] @ partitions, 
  3]

enter image description here

Use 4 bins instead of 3:

Multicolumn[
 ReplaceAll[{ {} -> "-", p : {(a | b | c) ..} :> StringRiffle[p, ""]}]@
  kPartitions[{a, b, c}, 4], 
 8]

enter image description here

$\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.