4
$\begingroup$

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

$\endgroup$
3
  • $\begingroup$ aren't there some lists missing in your output, such as e.g. {1,2,1,2,1,2}? $\endgroup$ Oct 21, 2013 at 9:19
  • $\begingroup$ "parts less then l cound not be neighbor" in my case l=3, so 1 and 2 cannot be neighbor $\endgroup$ Oct 21, 2013 at 9:21
  • $\begingroup$ ah, ok, I understood 1 and 1 (and also 2 and 2) cannot be neighbor. Got it! $\endgroup$ Oct 21, 2013 at 9:22

3 Answers 3

5
$\begingroup$

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}}} *)
$\endgroup$
8
  • $\begingroup$ This is wonderful $\endgroup$
    – ubpdqn
    Oct 21, 2013 at 13:18
  • $\begingroup$ ... it took me longer to understand how you exactly do it than to write my answer. Big +1. $\endgroup$ Oct 21, 2013 at 13:33
  • $\begingroup$ @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. $\endgroup$ Oct 21, 2013 at 13:36
  • $\begingroup$ @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) $\endgroup$ Oct 21, 2013 at 13:39
  • $\begingroup$ @ubpdqn Thanks. I find linked lists useful in such cases as this. $\endgroup$ Oct 21, 2013 at 13:54
3
$\begingroup$

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)

$\endgroup$
2
  • $\begingroup$ Yes, I would like to use it for Large numbers $\endgroup$ Oct 21, 2013 at 12:00
  • $\begingroup$ ok, well, you will definitely like @LeonidShifrin's answer then! $\endgroup$ Oct 21, 2013 at 13:13
1
$\begingroup$

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}}
$\endgroup$

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.