Finding specific compositions of an Integer

Question

I need to find all compositions of an integer L wherein all parts do not exсeed l and parts less then l cound not be neighbor. Here is my code

test[arr0_, ll0_] :=
  Module[{arr = arr0, ll = ll0},
   result = True;
   For[i = 1, i < Length[arr], i++, 
    If[arr[[i]] < ll && arr[[i + 1]] < ll, result = False]];
   result
   ];
frag[L0_, l0_] :=
  Module[{L = L0, l = l0},
   part = IntegerPartitions[L, 2*Ceiling[L/l] + 1, Range[l]];
   part = Flatten[Map[Permutations[#] &, part], 1];
   Select[part, test[#, l] &]
   ];
frag[9, 3]

Output: {{3, 3, 3}, {3, 2, 3, 1}, {3, 1, 3, 2}, {2, 3, 3, 1}, {2, 3, 1, 3}, {1, 3, 3, 2}, {1, 3, 2, 3}, {1, 3, 1, 3, 1}}

I guess Mathematica allows to solve this problem much more easier

aren't there some lists missing in your output, such as e.g. {1,2,1,2,1,2}? — Pinguin Dirk, Oct 21 '13 at 09:19
"parts less then l cound not be neighbor" in my case l=3, so 1 and 2 cannot be neighbor — Филипп Цветков, Oct 21 '13 at 09:21
ah, ok, I understood 1 and 1 (and also 2 and 2) cannot be neighbor. Got it! — Pinguin Dirk, Oct 21 '13 at 09:22

score 5 · Accepted Answer · answered Oct 21 '13 at 12:52

5

The problem of solutions posted so far (including yours) is that they could not take into account the limitation on the size and placement of parts of the partitions, and therefore had to consider a much larger search space, unnecessarily.

Here is a recursive solution based on linked lists and not using any built-in functions:

ClearAll[parts];
parts[accum_,0,_]:= parts[Flatten[accum]];
parts[_,_?Negative,_]:={};
parts[accum:{_,last_},num_,lim_]/;last<lim:=
    parts[{accum,lim},num-lim,lim];
parts[accum_,num_,lim_]:=
    (parts[{accum,#1},num-#1,lim]&)/@Range[lim];
parts[num_,lim_]:=
    Cases[parts[{},num,lim],parts[x_List]:>x,\[Infinity]];

What it does is to build a tree and then pick the valid combinations from it, using Cases (bad combinations result in {}, while valid ones have the form parts[combination]). Since here I have the access to the fine-grained details of the algorithm, I can ensure that a number of bad combinations will be filtered out right when we are building the tree, which reduces the search space significantly.

For example:

parts[9, 3]

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

This one is also quite reasonable in terms of run-time and memory efficiency:

parts[40,5]//Short//AbsoluteTiming

(* {0.163907,{{1,5,1,5,1,5,1,5,1,5,1,5,4},<<6825>>,{5,5,5,5,5,5,5,5}}} *)

answered Oct 21 '13 at 12:52

Leonid Shifrin

114,335
15
329
420

This is wonderful – ubpdqn Oct 21 '13 at 13:18
... it took me longer to understand how you exactly do it than to write my answer. Big +1. – Pinguin Dirk Oct 21 '13 at 13:33
@PinguinDirk Thanks, but this means that I didn't explain it well. I thought the code is more or less self-explanatory. Perhaps I should have added links to similar solutions I posted before. – Leonid Shifrin Oct 21 '13 at 13:36
@LeonidShifrin: don't base it on my opinion alone, your explanation is great as it is - it just took a bit till I got my head around the accum (I just had to work an example, further expl. wouldn't change that, I guess) – Pinguin Dirk Oct 21 '13 at 13:39
@ubpdqn Thanks. I find linked lists useful in such cases as this. – Leonid Shifrin Oct 21 '13 at 13:54
@LeonidShifrin. Thank you! You are really strong! Maybe you could help me with another problem described here http://math.stackexchange.com/questions/531330/random-filling-of-l-length-line-with-l-length-segments-discrete-case – Филипп Цветков Oct 21 '13 at 19:12
Sorry, but to stay sane, I restricted my helping activities to Mathematica programming only :). Thanks for the accept. – Leonid Shifrin Oct 21 '13 at 19:18
@LeonidShifrin I post the problem with Mathematica code here http://mathematica.stackexchange.com/questions/34514/random-filling-of-l-length-line-with-l-length-segments – Филипп Цветков Oct 21 '13 at 20:00

score 3 · Answer 2 · answered Oct 21 '13 at 09:26

3

I hope I understood it right, how about this:

doIt[int_Integer, l_Integer] := 
   DeleteCases[
     Flatten[Permutations /@ IntegerPartitions[int, int, Range[l]], 1], 
     {___, Alternatives @@ Range[l - 1], Alternatives @@ Range[l - 1], ___}];

doIt[9, 3]

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

are you going to use this on large numbers? That'll be slow... (using IntegerPartitions and Permutation)

answered Oct 21 '13 at 09:26

Pinguin Dirk

6,519
1
26
36

Yes, I would like to use it for Large numbers – Филипп Цветков Oct 21 '13 at 12:00
ok, well, you will definitely like @LeonidShifrin's answer then! – Pinguin Dirk Oct 21 '13 at 13:13

score 1 · Answer 3 · answered Oct 21 '13 at 09:38

Not neat but another approach...agree scaling issues

f[p_, n_] := 
  Select[Select[IntegerPartitions[p], And @@ (# <= n & /@ #) &], 
   Count[#, n] >= Floor[Length[#]/2] &];
test[x_, n_] := 
  Length[Cases[Partition[x, 2, 1], {_?(# < n &), _?(# < n &)}]] == 0;
frag[x_, n_] := 
 Join @@ Map[Select[Permutations[#], test[#, n] &] &, f[x, n]]

frag[9,3] yields:

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

frag[10,3]:

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

Finding specific compositions of an Integer

3 Answers3

Linked