Generate lists with a constraint

Question

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.

Answer 1

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}}

Answer 2

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}} *)

Answer 3

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])]

Answer 4

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}}

Answer 5

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
]

Answer 6

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.