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$
  • $\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 '17 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 '17 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 '17 at 17:11
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$
  • $\begingroup$ That Shuffle Product question was a fun problem, good to see it put to use... $\endgroup$ – ciao Feb 23 '17 at 23:11
  • $\begingroup$ Seems to be missing results: {0,0,1,0,2,0,3} ? $\endgroup$ – ciao Feb 24 '17 at 8:44
  • $\begingroup$ And the result {0,1,0,2,0,3,0} appears twice. $\endgroup$ – drer Feb 24 '17 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 '17 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 '17 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$
  • $\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 '17 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 '17 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 '17 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 '17 at 14:01
  • $\begingroup$ Thanks, @Mr.Wizard. I will add it once checked. $\endgroup$ – march Feb 24 '17 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$
  • $\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 '17 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 '17 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 '17 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 '17 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$
  • $\begingroup$ Your answer seems to be neither general nor complete. $\endgroup$ – DPF Feb 23 '17 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 '17 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$ – David G. Stork Mar 2 '17 at 17:04

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.