6
$\begingroup$

How can I visualise/represent "Stars and Bars" in Mathematica?

Say I have $n$ balls and $k$ slots to fill (or not to fill) with balls, e.g. when $n=4$ and $k=4$,

**|*||*, ***|||*, ...

There are two cases to consider: a) no slots are allowed to be empty and b) a slot/several slots are allowed to be empty.

I thought that a representation with tuples would be good, e.g. {2, 1, 0, 1} and {3, 0, 0, 1} for the two samples above.

I tried with Tuples but did not get anywhere. Does anyone have a solution?

TIA.

$\endgroup$
9
$\begingroup$

Here's one possibility:

With[{n = 4, k = 4}, 
     StringJoin[Riffle[Table["*", {#}] & /@ #, "|"]] & /@ FrobeniusSolve[Table[1, {k}], n]]
   {"|||****", "||*|***", "||**|**", "||***|*", "||****|", "|*||***", "|*|*|**", "|*|**|*",
    "|*|***|", "|**||**", "|**|*|*", "|**|**|", "|***||*", "|***|*|", "|****||", "*|||***",
    "*||*|**", "*||**|*", "*||***|", "*|*||**", "*|*|*|*", "*|*|**|", "*|**||*", "*|**|*|",
    "*|***||", "**|||**", "**||*|*", "**||**|", "**|*||*", "**|*|*|", "**|**||", "***|||*",
    "***||*|", "***|*||", "****|||"}

In a comment, Jim shows that you can use IntegerPartitions[] + Permutations[] instead:

With[{n = 4, k = 4}, 
     StringJoin[Riffle[Table["*", {#}] & /@ #, "|"]] & /@ 
     Flatten[Permutations /@ IntegerPartitions[n + k, {k}] - 1, 1]]

which should yield the same result as above.


The OP also wanted to consider the case where empty slots are not allowed; a slight modification of Jim's suggestion does this. Using a different example:

With[{n = 7, k = 4}, 
     StringJoin[Riffle[Table["*", {#}] & /@ #, "|"]] & /@ 
     Flatten[Permutations /@ IntegerPartitions[n, {k}], 1]]
   {"****|*|*|*", "*|****|*|*", "*|*|****|*", "*|*|*|****", "***|**|*|*", "***|*|**|*",
    "***|*|*|**", "**|***|*|*", "**|*|***|*", "**|*|*|***", "*|***|**|*", "*|***|*|**",
    "*|**|***|*", "*|**|*|***", "*|*|***|**", "*|*|**|***", "**|**|**|*", "**|**|*|**",
    "**|*|**|**", "*|**|**|**"}
$\endgroup$
5
  • $\begingroup$ Are you sure about removing dupes? With[{n = 4, k = 4}, StringJoin[Riffle[Table["*", {#}] & /@ #, "|"]] & /@ (-Table[1, {k}] + # & /@ Flatten[Permutations[#] & /@ IntegerPartitions[n + k, {k}], 1])] doesn't seem to require the removal of dupes and is just slightly faster. $\endgroup$
    – JimB
    Nov 15 '19 at 0:15
  • $\begingroup$ That offsetting trick is neat, thanks @Jim! I'll edit this answer in a little bit. $\endgroup$
    – J. M.'s torpor
    Nov 15 '19 at 0:20
  • $\begingroup$ Is it possible to also get an "numeral output" i.e. {{4,1,1,1}, {1,4,1,1}...} etc.? $\endgroup$
    – mf67
    Nov 15 '19 at 23:23
  • $\begingroup$ @mf67, the part after the second /@ is the numerical version; e.g. Flatten[Permutations /@ IntegerPartitions[n, {k}], 1]. $\endgroup$
    – J. M.'s torpor
    Nov 15 '19 at 23:46
  • $\begingroup$ Thanks. Very neat. (My lack of Mathematica knowledge is apparent.) $\endgroup$
    – mf67
    Nov 16 '19 at 16:56
2
$\begingroup$

★'s and |'s with string manipulations. Use Method to switch between "Positivity" (default) and "Nonnegativity".

ClearAll[starsAndBars]
Options[starsAndBars] = {Method -> "Positivity"};
starsAndBars[n_Integer?Positive, k_Integer?Positive, opts : OptionsPattern[starsAndBars]] :=
 Module[{ip = Switch[OptionValue[Method], "Positivity", {k}, "Nonnegativity", {1, k}]},
  StringReplace[{", " -> "|", "0" -> "", num : NumberString :> StringRepeat["★", FromDigits@num]}]@
   StringTake[
    ToString /@
     Flatten[
      Permutations@*Flatten@{#, ConstantArray[0, k - Length@#]} & /@ IntegerPartitions[n, ip]
      , 1]
    , {2, -2}]
  ]

Under "Positivity"

starsAndBars[4, 3] 
{★★|★|★,★|★★|★,★|★|★★}

Under "Nonnegativity"

starsAndBars[4, 3, Method -> "Nonnegativity"] 
{★★★★||,|★★★★|,||★★★★,★★★|★|,★★★||★,
 ★|★★★|,★||★★★,|★★★|★,|★|★★★,★★|★★|,
 ★★||★★,|★★|★★,★★|★|★,★|★★|★,★|★|★★}

Empty set under "Positivity" with no solutions.

starsAndBars[4, 5, Method -> "Positivity"]
{}

Hope this helps.

$\endgroup$
2
  • 1
    $\begingroup$ I would replace Flatten[Permutations @* Flatten @ {#, ConstantArray[0, k - Length @ #]} & /@ IntegerPartitions[n, ip], 1] with Flatten[Permutations /@ PadRight[IntegerPartitions[n, ip], {Automatic, k}], 1]. $\endgroup$
    – J. M.'s torpor
    Nov 15 '19 at 3:43
  • $\begingroup$ @J.M.willbebacksoon That is a good suggestion. Thanks. $\endgroup$
    – Edmund
    Nov 16 '19 at 12:56

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.