# How can I combine two Pick expressions into one?

I want to speed up my code, i.e., replace Select by Pick. I think using two Pick expressions isn't pretty, but I have no good idea on how to combine them.

Select[Permutations@ Range@9,
#1 < #4 < #7 && #1/(10 #2 + #3) + #4/(10 #5 + #6) + #7/(10 #8 + #9) == 1 & @@ # &]

Pick[#, #1/(10 #2 + #3) + #4/(10 #5 + #6) + #7/(10 #8 + #9) & @@ Transpose @ #, 1] & @
Pick[#, Thread[#1 < #4 < #7] & @@ Transpose@#] & @ Permutations @ Range @ 9

• "I think two Pick isn't pretty..." - sure, but at least the second Pick[] has less to choose from, which is a good thing. – J. M. will be back soon May 3 '13 at 16:47

One way to speed things up is to use internally fast functions ("vectorized" ones).

Another consideration is that machine-size integer arithmetic is faster than exact rational arithmetic. If we clear denominators in the second criteria it turns out to be faster.

pickCriteria = Compile[{{perms, _Integer, 2}},
#[[1]] #[[5]] #[[6]] + #[[2]] #[[4]] #[[6]] + #[[3]] #[[4]] #[[5]] - #[[4]] #[[5]] #[[6]] &[
{{1, 0, 0, 0, 0, 0, 0, 0, 0},   (* equals part 1 *)
{0, 0, 0, 1, 0, 0, 0, 0, 0},   (* equals part 4 *)
{0, 0, 0, 0, 0, 0, 1, 0, 0},   (* equals part 7 *)
{0, 10, 1, 0, 0, 0, 0, 0, 0},  (* equals 10 * part 2 + part 3 *)
{0, 0, 0, 0, 10, 1, 0, 0, 0},  (* equals 10 * part 5 + part 6 *)
{0, 0, 0, 0, 0, 0, 0, 10, 1}   (* equals 10 * part 8 + part 9 *)
} . Transpose @ perms]
];
Pick[#, Thread[#[[1]] < #[[4]] < #[[7]]] &@ Transpose@#] &@
Pick[#, pickCriteria[#], 0] &@ Permutations @ Range @ 9 // Timing
(* {0.134507, {{5, 3, 4, 7, 6, 8, 9, 1, 2}}} *)


The OP's two versions take 1.795493 and 0.873528 seconds respectively.

Real arithmetic is also fast, but approximate. A little bit slower than the above.

pickCriteriaReal = Compile[{{perms, _Real, 2}},
Sign @ Chop[#[[1]]/#[[4]] + #[[2]]/#[[5]] + #[[3]]/#[[6]] - 1.] &[
{{1., 0., 0., 0., 0., 0., 0., 0., 0.},
{0., 0., 0., 1., 0., 0., 0., 0., 0.},
{0., 0., 0., 0., 0., 0., 1., 0., 0.},
{0., 10., 1., 0., 0., 0., 0., 0., 0.},
{0., 0., 0., 0., 10., 1., 0., 0., 0.},
{0., 0., 0., 0., 0., 0., 0., 10., 1.}
} . Transpose @ perms]
];
Pick[#, Thread[#[[1]] < #[[4]] < #[[7]]] &@ Transpose @ #] &@
Pick[#, pickCriteriaReal[#], 0] &@ Permutations @ N @ Range @ 9 //
Round // Timing
(* {0.205289, {{5, 3, 4, 7, 6, 8, 9, 1, 2}}} *)

• Thanks for help. Machine-size integer indeed fast, this also take 0.2 seconds: Pick[#, #1 (10 #5 + #6) (10 #8 + #9) + 10 #2 ((10 #5 + #6) (#7 - 10 #8 - #9) + #4 (10 #8 + #9)) + #3 ((10 #5 + #6) (#7 - 10 #8 - #9) + #4 (10 #8 + #9)) & @@ Transpose@#, 0] &@Permutations@Range@9 // Timing – chyanog May 4 '13 at 18:01
Pick[#, Sign[(#1 - #4)] + Sign[(#4 - #7)] +
#1/(10.0 #2 + #3) + #4/(10.0 #5 + #6) +#7/(10.0 #8 + #9) & @@
Transpose@#, 1. - 2] &@ Permutations@Range@9 // Timing

(*{1.138807, {{5, 3, 4, 7, 6, 8, 9, 1, 2}}}*)


More faster version (Thanks @Michael E2):

Pick[#, Function[{a, b, c, d, e, f, g, h, i},
Evaluate[ Sign[a - d] + Sign[d - g] +
Simplify[a/(10 b + c) + d/(10 e + f) + g/(10 h + i) - 1 // Together // Numerator]]
] @@ Transpose@#, -2] &@Permutations@Range@9 // Timing

(*{0.218401, {{5, 3, 4, 7, 6, 8, 9, 1, 2}}}*)


Or

Pick[#, Function[{a, b, c, d, e, f, g, h, i},
Evaluate@Simplify[a/(10 b + c) + d/(10 e + f) + g/(10 h + i) - 1 // Together //
Numerator]] @@ Transpose@#, 0] &@
Pick[#, Sign[(#1 - #4)] + Sign[(#4 - #7)] & @@ Transpose@#, -2] &@
Permutations@Range@9 // Timing

(*{0.109201, {{5, 3, 4, 7, 6, 8, 9, 1, 2}}}*)

• Yours takes 0.067 sec. on my machine -- much faster than mine. The use of Sign[#1-#4] etc. in place of Less saves a lot of time, I think. – Michael E2 May 4 '13 at 18:48

Replaced by one equivalent Pick, but the net result is a slowdown ...

Pick[#, #1 < #4 < #7 && #1/(10 #2 + #3) + #4/(10 #5 + #6) + #7/(10 #8 + #9) == 1 & @@@ #] &@
Permutations@Range@9