1
$\begingroup$

I have this code for sorting only those tuples that sum to 15 without repetition:

n = 15;s=11; m = 3; 
ip = IntegerPartitions[n, {m}]; 
v =  Pick[ip, Max@# < s & /@ ip];
DeleteCases[v, x_ /; x[[1]] == x[[2]] || x[[2]] == x[[3]]]

Output:

{{9, 5, 1}, {9, 4, 2}, {8, 6, 1}, {8, 5, 2}, {8, 4, 3}, {7, 6, 2}, {7, 5, 3}, {6, 5, 4}}

but with:

n = 45;s = 15;m = 8;
ip = IntegerPartitions[n, {m}]; 
v = Pick[ip, Max@# < s & /@ ip];
DeleteCases[v, x_ /; x[[1]] == x[[2]] || x[[2]] == x[[3]] || x[[3]] == x[[4]] || 
  x[[4]] == x[[5]] || x[[5]] == x[[6]] || x[[6]] == x[[7]] ||x[[7]] == x[[8]]]

Pattern in DeleteCases[] is too long. How to write code in a simpler and more elegant way?

$\endgroup$
7
  • $\begingroup$ Select[ip, Max @@ # < s && Length@DeleteDuplicates@# == m &] $\endgroup$ Apr 7 '15 at 12:41
  • $\begingroup$ Max@# < s & /@ ip does not give total sum of 15, but sublists with max value smaller than s. Somehow, did I missed understanding your question? $\endgroup$
    – penguin77
    Apr 7 '15 at 12:46
  • $\begingroup$ Your code seems to produce: {{10, 4, 1}, {10, 3, 2}, {9, 5, 1}, {9, 4, 2}, {8, 6, 1}, {8, 5, 2}, {8, 4, 3}, {7, 6, 2}, {7, 5, 3}, {6, 5, 4}} and not the output, shown in your question $\endgroup$
    – penguin77
    Apr 7 '15 at 12:49
  • $\begingroup$ @penguin77 Yes his thas {{9, 5, 1}=15,{6, 5, 4}=15}..... $\endgroup$ Apr 7 '15 at 12:50
  • $\begingroup$ @belisarius your code is 3 time slower than my.How to speed up? $\endgroup$ Apr 7 '15 at 12:52
2
$\begingroup$

You may consider this to produce same result as your code:

n = 15; s = 11; m = 3;
ip = IntegerPartitions[n, {m}];
Select[ip, Max @@ # < s && DuplicateFreeQ@# &]
$\endgroup$
6
  • $\begingroup$ Total == 15? That's already guaranteed by IntegerPartitions[n]. $\endgroup$
    – rcollyer
    Apr 7 '15 at 13:16
  • $\begingroup$ @rcollyer, yes of course, thx, i will correct. $\endgroup$
    – penguin77
    Apr 7 '15 at 13:22
  • 2
    $\begingroup$ The only reason I focused on your answer was I was working on the same thing ... That said, I'd use Max[#] < s && DuplicateFreeQ[#] & for your predicate in Select as Apply is unnecessary for Max to work and it doesn't unpack. Also, if you pack ip, e.g. DeveloperToPackedArray@IntegerPartitions[n, {m}];` even with n = 45, it's faster than Pick. $\endgroup$
    – rcollyer
    Apr 7 '15 at 13:22
  • $\begingroup$ Oh, and DuplicateFreeQ was genius. $\endgroup$
    – rcollyer
    Apr 7 '15 at 13:23
  • $\begingroup$ @penguin77 .Code of Michael E2 is best. Operating time is the shortest. $\endgroup$ Apr 7 '15 at 13:24
5
$\begingroup$

Update: Use the third argument of IntegerPartitions to get further simplification:

n = 15; s = 11; m = 3;
ipa = IntegerPartitions[n, {m}, Range[s - 1]]

Using it in Pick with @penguin77's DuplicateFreeQ or with @Michael E2's Unitize[...]:

va1 = Pick[ipa, DuplicateFreeQ /@ ipa];
va2 = Pick[ipa, Unitize[Times @@ Differences@Transpose[ipa]] , 1]
va1 == va2 == v2
(* True *)

Original answer:

You can modify the selector array (the second argument) inside Pick to get the result in one step:

n = 15; s = 11; m = 3;
ip2 = IntegerPartitions[n, {m}];
v2 = Pick[ip2, (Unequal @@ # && Max@# < s) & /@ ip2];
v2 // Grid 

enter image description here

n = 45; s = 15; m = 8;
ip3 = IntegerPartitions[n, {m}];
v3 = Pick[ip3, (Unequal @@ # && Max@# < s) & /@ ip3];
v3 // Grid

enter image description here

$\endgroup$
6
  • $\begingroup$ I believe you may replace Max by Firstsince the tuples are already sorted. That should be faster (at least theoretically) $\endgroup$ Apr 7 '15 at 13:41
  • $\begingroup$ @belisarius I don't see any speed difference between using Max and First. But, switching from Unequal @@ # to DuplicateFreeQ@# does give a speed up. Note, these are still small, and Michael's is an order of magnitude faster. $\endgroup$
    – rcollyer
    Apr 7 '15 at 13:45
  • $\begingroup$ @rcollyer That was why I said "theoretically" : s=10; ip = RandomInteger[{1, 10}, {10000, 1000}]; Print@Timing[Pick[ip, (Max@# < s) & /@ ip];]; Print@Timing[Pick[ip, (First@# < s) & /@ ip];] $\endgroup$ Apr 7 '15 at 13:47
  • $\begingroup$ @belisarius, good point re First vs Max, thank you. We can eliminate the need for either by using the third argument of IntegerPartitions in construction of ip. $\endgroup$
    – kglr
    Apr 7 '15 at 14:18
  • $\begingroup$ True, that's really better. $\endgroup$ Apr 7 '15 at 14:20
1
$\begingroup$

This produces the same output as your code:

Pick[ip,
 UnitStep[(s - 1) - ip[[All, 1]]] Unitize[Times @@ Differences@Transpose[ip]], 1]
(*
  {{10, 4, 1}, {10, 3, 2}, {9, 5, 1}, {9, 4, 2}, {8, 6, 1},
   {8, 5, 2}, {8, 4, 3}, {7, 6, 2}, {7, 5, 3}, {6, 5, 4}}
*)

To get the output written in the question, adjust as follows:

Pick[ip,
 UnitStep[(s - 2) - ip[[All, 1]]] Unitize[Times @@ Differences@Transpose[ip]], 1]
$\endgroup$
4
  • $\begingroup$ .....................Thanks :) $\endgroup$ Apr 7 '15 at 13:11
  • $\begingroup$ @Mariusz the answers have barely started to come in. You should wait a while before accepting an answer. $\endgroup$
    – rcollyer
    Apr 7 '15 at 13:15
  • $\begingroup$ @rcollyer. What should I wait? But already the answer is correct. This has just wanted to. $\endgroup$ Apr 7 '15 at 13:29
  • 2
    $\begingroup$ @Mariusz because choosing an answer discourages further answers which may or may not be better, but illustrate some other way of doing things. Or, discuss issues that you haven't considered. There are usually 8 or 9 ways to accomplish most things in Mathematica. Also, it is not uncommon for a late answer to completely alter a view of a problem, for example:(1), (2). So, holding off, even for a couple of hours gives others a chance at being noticed. $\endgroup$
    – rcollyer
    Apr 7 '15 at 13:40

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.