Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

share|improve this question
    
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 9: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 9:21
    
ah, ok, I understood 1 and 1 (and also 2 and 2) cannot be neighbor. Got it! –  Pinguin Dirk Oct 21 '13 at 9:22
add comment

3 Answers

up vote 5 down vote accepted

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}}} *)
share|improve this answer
    
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
show 3 more comments

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)

share|improve this answer
    
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
add comment

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}}
share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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