6
$\begingroup$

I have just started using Mathematica, therefore please excuse possibly stupid questions.

I need to generate a list of specific distributions of $k$ ordered objects into $n>=2k$ cells, such that the order of the objects is preserved and every pair of them is separated by at least one 0-element. The last and the first element also have to be separated by 0, as if the sequence were cyclic.

For example given the set {1,2,3} the result should be:

for n<=5:

{}

for n=6

{{1, 0, 2, 0, 3, 0}, {0, 1, 0, 2, 0, 3}}

for n=7:

{{1, 0, 2, 0, 3, 0, 0}, {1, 0, 2, 0, 0, 3, 0}, {1, 0, 0, 2, 0, 3, 0},
 {0, 1, 0, 2, 0, 3, 0}, {0, 1, 0, 2, 0, 0, 3}, {0, 1, 0, 0, 2, 0, 3},
 {0, 0, 1, 0, 2, 0, 3}}

and so on.

I am looking for an efficient solution, which can be applied for large $k$ and $n$.

ps. I know the solution involving generation of all permutations of {0,0,0,0,1,2,3} with subsequent rejection of the false sequences but it is certainly very inefficient one.

$\endgroup$
3
  • $\begingroup$ You could try to combine Permutations with Riffle and add enough zeros to the list for larger values of n $\endgroup$
    – grbl
    Feb 23, 2017 at 16:08
  • $\begingroup$ Thank you for the advice. It can be really useful, if it is possible to split $n-k$ zeros into $k$ non-empty groups. But I hope for a solution similar to that one posted for a similar problem by @Leonid Shifrin: mathematica.stackexchange.com/questions/34468/…. To my sorry I understand almost nothing from this code, but it does work. $\endgroup$
    – drer
    Feb 23, 2017 at 16:53
  • 1
    $\begingroup$ Perhaps you could convert Table[{i,j,k}, {i, 1, 3}, {j, i+2, 5}, {k, j+2, 7}] into a recursive function? The Table call produces a list of triplets for where the nonzero entries are positioned. $\endgroup$
    – Carl Woll
    Feb 23, 2017 at 17:11

6 Answers 6

6
$\begingroup$

For performance I shall use shuffleW from my answer to Shuffle product of two lists.
shuffleW was coauthored with ciao.

Note: my attempt to eliminate Union was a failure, producing invalid output. I am restoring a version with Union to correct this.

shuffleW[s1_, s2_] := 
  Module[{p, tp, ord},
    p = Permutations @ Join[1 & /@ s1, 0 & /@ s2]\[Transpose];
    tp = BitXor[p, 1];
    ord = Accumulate[p] p + (Accumulate[tp] + Length[s1]) tp;
    Outer[Part, {Join[s1, s2]}, ord, 1][[1]]\[Transpose]
  ]

solution[in_List, n_] /; n < 2 Length[in] := {}  

solution[in_List, n_] := 
  # ⋃ RotateRight[#, {0, 1}] &[
    Flatten /@ shuffleW[ {#, 0} & /@ in, Table[0, {n - 2 Length[in]}] ] ]

Test:

solution[{1, 2, 3}, 5]

solution[{1, 2, 3}, 6]

solution[{1, 2, 3}, 7]

solution[{}, 7]
{}

{{0, 1, 0, 2, 0, 3}, {1, 0, 2, 0, 3, 0}}

{{0, 0, 1, 0, 2, 0, 3}, {0, 1, 0, 0, 2, 0, 3}, {0, 1, 0, 2, 0, 0, 3},
 {0, 1, 0, 2, 0, 3, 0}, {1, 0, 0, 2, 0, 3, 0}, {1, 0, 2, 0, 0, 3, 0},
 {1, 0, 2, 0, 3, 0, 0}}

{{0, 0, 0, 0, 0, 0, 0}}

Carl Woll's comment

Carl Woll commented on a relation to Table. Here is an implementation of that.

solCW[in_, n_] := 
  With[{m = Length@in}, 
    With[{syms = Unique[Table["x", {m}], Temporary]}, 
      Array[{syms[[#]], syms[[# - 1]] + 2 /. List -> -1, n - 2 (m - #)} &, m]
       // MapAt[n - 1 + Sign[syms[[1]] - 1] &, #, {-1, -1}] &
       // Apply[Table[syms, ##] ~Flatten~ (m - 1) &]
       // Map[SparseArray[# -> in, n] &]
       // Normal
    ]
  ]

solCW[{a, b, c}, 7]
{{a, 0, b, 0, c, 0, 0}, {a, 0, b, 0, 0, c, 0}, {a, 0, 0, b, 0, c, 0},
 {0, a, 0, b, 0, c, 0}, {0, a, 0, b, 0, 0, c}, {0, a, 0, 0, b, 0, c},
 {0, 0, a, 0, b, 0, c}}
$\endgroup$
18
  • $\begingroup$ That Shuffle Product question was a fun problem, good to see it put to use... $\endgroup$
    – ciao
    Feb 23, 2017 at 23:11
  • $\begingroup$ Seems to be missing results: {0,0,1,0,2,0,3} ? $\endgroup$
    – ciao
    Feb 24, 2017 at 8:44
  • $\begingroup$ And the result {0,1,0,2,0,3,0} appears twice. $\endgroup$
    – drer
    Feb 24, 2017 at 9:08
  • $\begingroup$ @Mr.Wizard Thank you very much for your answer and especially for the reference to the Shuffle topic. I wonder however if it is possible still optimize the shufflew code in applying to this particular problem, as the latter is much simpler (the elements of one set are all identical). What concerns your answer, is it not faster first to riffle the initial set with $k$ zeros, declare it as a set of pairs {0,in[[i]]}, then shuffle it with $n-2k+1$ zeros, and in the end remove the first 0? $\endgroup$
    – drer
    Feb 24, 2017 at 9:34
  • 1
    $\begingroup$ @Mr.Wizard: I'll take a look when time permits: if it's interesting to you, it will surely be to me. I'm working right now on a package to donate to the community with a set of high-performance probability functions that duplicate MMA functionality but are much faster (e.g., don't know if you saw my recent multinomial CDF ) which is keeping me busy, so it may be a while. $\endgroup$
    – ciao
    Feb 25, 2017 at 0:31
4
$\begingroup$

Borrowing Mr. Wizard's naming convention, we have

solution[in_List, n_] := With[{l = Length@in},
  Flatten@Riffle[in, #] & /@ Map[ConstantArray[0, #] &, Join @@ Permutations /@ IntegerPartitions[n - l, {l}], {2}]
 ]

The core of the idea is to use IntegerPartitions on the difference between the n and k to get the different numbers of 0's that go between the numbers. This generates all the lists with zeros at the end. To extend it to all of the lists, Map the following function over the result:

extend = Sequence @@ Table[RotateRight[#, n], {n, 0, FirstPosition[Reverse@#, _?Positive][[1]] - 1}]) &;

Usage:

extend /@ solution[Range[3], 7]
(* {{1, 0, 0, 2, 0, 3, 0}, {0, 1, 0, 0, 2, 0, 3}, {1, 0, 2, 0, 0, 3, 0},
    {0, 1, 0, 2, 0, 0, 3}, {1, 0, 2, 0, 3, 0, 0}, {0, 1, 0, 2, 0, 3, 0},
    {0, 0, 1, 0, 2, 0, 3}} *)
$\endgroup$
6
  • $\begingroup$ @Mr.Wizard. Yes thanks! I figured I'd use your same terminology and obviously forgot to change it between the two. Fixed. $\endgroup$
    – march
    Feb 23, 2017 at 19:34
  • $\begingroup$ I think mapping this function across your result will make complete output: extend = Sequence @@ Table[RotateRight[#, n], {n, 0, FirstPosition[Reverse@#, _?Positive][[1]] - 1}] &; $\endgroup$
    – Mr.Wizard
    Feb 23, 2017 at 19:50
  • $\begingroup$ I can suggest a nice fix to the preliminary version. At the beginning just add 1 to both arguments of IntegerPartitions. Then after the flatting of the Permutations result, double the set by decrementing either the first or the last element of each list. Finally swap the arguments of the Riffle. I am however not sure, that this nice solution is faster than the one suggested by @Mr.Wisard. To my sorry I was not able to add the code realizing the decrement of the first and last element in a nice way you are using Mathematica. I would very appreciate if you show how to do this. $\endgroup$
    – drer
    Feb 24, 2017 at 8:49
  • $\begingroup$ My suggestion has appeared wrong. It produces unnecessary duplicates. I will post the correct solution (without claiming it is an efficient one) below. $\endgroup$
    – drer
    Feb 24, 2017 at 14:01
  • $\begingroup$ Thanks, @Mr.Wizard. I will add it once checked. $\endgroup$
    – march
    Feb 24, 2017 at 18:31
3
$\begingroup$

Not efficient but:

func[lst_, n_] := 
 Module[{perm = Permutations[lst~Join~Table[0, n - Length[lst]]],
   r = {0 ...}~Join~Riffle[lst, 0 ..]~Join~{0 ...}},
  DeleteCases[Cases[perm, r], {_?(# != 0 &), ___, __?(# != 0 &)}]]

e.g.

Row[MatrixPlot[#, ImageSize -> 100] & /@ (func[Range[3], #] & /@ 
    Range[6, 9])]

enter image description here

$\endgroup$
3
$\begingroup$

Here's a very quick-n-dirty entry. Seems fast as is, will revisit re: tuning when time permits.

do[l_, n_] :=
  Join @@ (NestList[RotateLeft, Flatten[Riffle[#, l]], 
       Length[#[[1]]]] & /@ Join @@ Permutations /@ 
          Map[ConstantArray[0, #] &, IntegerPartitions[n - Length@l, {Length@l}, 
               Range[1, n - Length@l + 1]], {2}]);

Usage:

do[{1,2,3},7]

{{0, 0, 1, 0, 2, 0, 3}, {0, 1, 0, 2, 0, 3, 0}, {1, 0, 2, 0, 3, 0, 0}, {0, 1, 0, 0, 2, 0, 3},

{1, 0, 0, 2, 0, 3, 0}, {0, 1, 0, 2, 0, 0, 3}, {1, 0, 2, 0, 0, 3, 0}}

$\endgroup$
2
$\begingroup$

First of all, I would like to thank everybody who took part in the discussion. I am still sure that shuffleWis probably the best choice to adapt for my problem. The other promising option were the indexing proposed by @Carl Woll. However it certainly exceeds my current level.

Yet I would like to present an algorithm correcting the version of @march. The algorithm is certainly not efficient enough, but it gives the correct answer without intermediate producing of reduntant sequences.

solution[in_List,n_]:=Module[{k=Length[in],s,ss},
s=Flatten[Permutations/@IntegerPartitions[n-k,{k+1}],1];
ss=Flatten[Permutations/@IntegerPartitions[n-k,{k}],1];
s=Join[Append[0]/@ss,s,Prepend[0]/@ss];
s=Table[0,{#}]&/@#&/@s; (* Taken from @march. Amusing construction. *) 
Table[Flatten[Riffle[s[[i]],in]],{i,Length[s]}]
]

solution[{1,2,3},7]

{{0,0,1,0,2,0,3},{0,1,0,0,2,0,3},{0,1,0,2,0,0,3},{0,1,0,2,0,3,0},{1,0,0,2,0,3,0},{1,0,2,0,0,3,0},{1,0,2,0,3,0,0}}

Besides the code

solution[{},7]

results in:

{{0,0,0,0,0,0,0}},

which was very desired (I forgot to mention it in my question).

============= EDIT 26.02.2017

On the advice of Mr.Wisard I have tried to adapt shuffleW code to my problem. I report here on the result.

First of all a function generating allowed binary permutations was constructed:

rp[m_,n_] := Module[{p,q,nn=Binomial[n,m],mm=Binomial[n-1,m-1],i,j,k},
If[n<m,Return[{{}}]];
p=ConstantArray[0,{mm+nn,m+n}];
q=Permutations[Join[ConstantArray[1,m],ConstantArray[0,n-m]]];
For[j=1,j≤mm,j++,k=1;For[i=1,i≤n,i++,If[q[[j,i]]==1,p[[j,k]]=1;k++];k++]];
For[j=1,j≤nn,j++,k=1;For[i=1,i≤n,i++,If[q[[j,i]]==1,k++;p[[j+mm,k]]=1];k++]];
p
]

Further the shuffleW code was reduced to:

shuffle0[s_, n_] := Module[{p, ord},
p = rp[Length[s],n-Length[s]]//Transpose;
ord = Accumulate[p] p + 1;
Outer[Part, {Join[{0}, s]}, ord, 1][[1]]//Transpose
]

The resulting code seems to be quite fast.

With original shuffleW code one can readily solve a more general problem. Given two sets s1,s2 (Length[s1]<=Length[s2]) find all the "shuffled" sequences, in which the elements of s1 are cyclically separated by at least one element of s2.

shuffleA[s1_,s2_] := Module[{p,tp,ord},
p = rp[Length[s1],Length[s2]]//Transpose;
tp = BitXor[p, 1];
ord = Accumulate[p] p + (Accumulate[tp] + Length[s1]) tp;
Outer[Part, {Join[s1,s2]}, ord, 1][[1]]//Transpose
]
$\endgroup$
4
  • $\begingroup$ By the way the algorithm provides a simple check for the overall number of the sequences: N=2Binomial[n-k-1,k-1]+Binomial[n-k-1,k]=Binomial[n-k-1,k-1]+Binomial[n-k,k]. $\endgroup$
    – drer
    Feb 24, 2017 at 16:58
  • $\begingroup$ Let me get this straight. You post "I am looking for an efficient solution...", then post an answer, after several others answer with efficient solutions, a solution with rather mediocre performance for non-trivial cases. What exactly was the purpose here? $\endgroup$
    – ciao
    Feb 25, 2017 at 0:05
  • $\begingroup$ @ciao I think you misunderstand. drer did not self-accept this. (And I will be disappointed if he does.) Instead he completed march's partial method in a different way from what I proposed. I think this is an interesting contribution even if inefficient. $\endgroup$
    – Mr.Wizard
    Feb 25, 2017 at 0:17
  • $\begingroup$ @ciao Mr.Wisard is absolutely right. My intention was solely to complete the march's solution, to make it producing correct result. You are also wrong that there were a lot of answers with efficient solutions. No of them (maybe except of yours, which I did not see at that time) gave the correct result without some refining (with unknown efficiency). Besides I wrote explicitely that I do not consider "my" solution as an efficient one. Actually I would prefer a form of a comment instead, but it allows too few characters. I will introduce minor changes to my answer to clarify this point. $\endgroup$
    – drer
    Feb 25, 2017 at 11:08
-1
$\begingroup$

Step by step:

mylist = {1, 2, 3};

Separate by a single 0:

list2 = Riffle[mylist, 0]

(* 
   {1, 0, 2, 0, 3}
*)

Add a zero at the beginning, and separately add a zero at the end:

list3 = {Prepend[list2, 0], Append[list2, 0]}

(* 
   {{0, 1, 0, 2, 0, 3}, {1, 0, 2, 0, 3, 0}}
*)

For each list Insert a 0 in every non-zero Position, plus the end, and eliminate duplicates.

addZero[lists : {__List}] :=
  Union @@ Table[
    Insert[a, 0, #] & /@ Position[Unitize @ Append[a, 1], 1],
    {a, lists}
  ]

addZero[list3]

(*
   {{0, 0, 1, 0, 2, 0, 3}, {0, 1, 0, 0, 2, 0, 3}, {0, 1, 0, 2, 0, 0, 3},
    {0, 1, 0, 2, 0, 3, 0}, {1, 0, 0, 2, 0, 3, 0}, {1, 0, 2, 0, 0, 3, 0},
    {1, 0, 2, 0, 3, 0, 0}}
*)

Repeat the application of addZero for every zero to be added, i.e. Nest.

$\endgroup$
3
  • $\begingroup$ Your answer seems to be neither general nor complete. $\endgroup$
    – DPF
    Feb 23, 2017 at 19:46
  • $\begingroup$ David, I don't like seeing your answer languishing in the negative so I completed your method and revised your answer. $\endgroup$
    – Mr.Wizard
    Mar 2, 2017 at 17:03
  • 1
    $\begingroup$ @Mr.Wizard: Many thanks for your efforts. I really appreciate it. (I've been swamped with other tasks and unable to devote the time to improving my "negative" answer.) $\endgroup$ Mar 2, 2017 at 17:04

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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