A conditional list generator with stored argument values

Question

I have already made this and the question is really about "how to make this faster and more general (to save the 4 keypresses of D,o,[ and ] that have to be made per-parameter)"

The function:

Reap[Do[Do[
Do[If[i + j + k > 6, Sow[Join[{i + j + k}, {{i, j, k}}]], 
  Nothing], {k, 3}], {j, 3}], {i, 3}]] // AbsoluteTiming

Output:

{0.0000826, {Null, {{{7, {1, 3, 3}}, {7, {2, 2, 3}}, {7, {2, 3, 
  2}}, {8, {2, 3, 3}}, {7, {3, 1, 3}}, {7, {3, 2, 2}}, {8, {3, 2, 
  3}}, {7, {3, 3, 1}}, {8, {3, 3, 2}}, {9, {3, 3, 3}}}}}}

The function essentially just does what Table[] does; aka it spits out all permutations of the variables and corresponding info that you feed into it, then deletes all of the entries that fail to comply to some constraints (in my example: i+j+k>6).

However the whole point is to do this deletion thingy as it is building the table instead of build the table first then check-and-delete which potentially ends up with 90%+ zero values or whatever we use for "nothing complies with the given constraints"; furthermore I do not care about the structure because I would massively prefer storing the actual values of the arguments (the numbers) instead of figuring out which nest of what nest some value is.

I have searched a bit about this and found about 2-3 very relevant threads here however none of which I believe have the exact thing that I want; my favourite of which is this thread https://stackoverflow.com/questions/6367932/generate-a-list-in-mathematica-with-a-conditional-tested-for-each-element

Specifically Leonid Shifrins answer.

His function with my example outputs:

{0.0002925, {{{7}}, {{7}, {7, 8}}, {{7}, {7, 8}, {7, 8, 9}}}}

(that is with AbsoluteTiming as well)

As you can see Shifrins code "loses information" about the values used to generate this. In other words if you only look at the output, you have no clue as to what made that first 7 for instance, it can be 7+0, 0+7, 3+4, 1+1+5, square root of 49, etc etc. I just want to store that information for each successful condition-pass instead of tossing it.

Also I believe I double evaluate which I would like to get rid of but all of my tries came out as infinite recursion (there is i+j+k inside Sow but also inside the conditional, so its evaluated twice where it doesnt need to be, in theory)

Thanks in advance.

Answer 1

Do does take multiple iterators. So, you can do

Reap[Do[If[i + j + k > 6, Sow[{i + j + k, {i, j, k}}]], {i, 3}, {j, 3}, {k, 3}]][[2]] 

{{{7, {1, 3, 3}}, {7, {2, 2, 3}}, {7, {2, 3, 2}}, {8, {2, 3, 3}}, 
  {7, {3, 1, 3}}, {7, {3, 2, 2}}, {8, {3, 2, 3}}, {7, {3, 3, 1}}, 
  {8, {3, 3, 2}}, {9, {3, 3, 3}}}} 

You can calculate i+j+k once for each step using something like:

Reap[Do[If[(v = i + j + k) > 6, Sow[{v, {i, j, k}}]], {i, 3}, {j, 3}, {k, 3}]][[2]] 

same result

You can also define a function similar to Simon's tableGenAlt:

ClearAll[f0]
f0 = Module[{ij = {##3}[[All, 1]]}, 
  Reap[Do[If[#2[# @@ ij], Sow[{# @@ ij, ij}]], ##3]][[2]]] &;

f0[Plus, GreaterThan[6], {i, 3}, {j, 3}, {k, 3}]

{{{7, {1, 3, 3}}, {7, {2, 2, 3}}, {7, {2, 3, 2}}, {8, {2, 3, 3}}, 
  {7, {3, 1, 3}}, {7, {3, 2, 2}}, {8, {3, 2, 3}}, {7, {3, 3, 1}}, 
  {8, {3, 3, 2}}, {9, {3, 3, 3}}}} 

Using a slight modification we can have more general test functions in the second argument:

ClearAll[f1]
f1 = Module[{ij = {##3}[[All, 1]]}, 
   Reap[Do[If[#2 @@ ij, Sow[{# @@ ij, ij}]], ##3]][[2]]] &;

f1[Plus, GreaterThan[6] @* Plus, {i, 3}, {j, 3}, {k, 3}] 

{{{7, {1, 3, 3}}, {7, {2, 2, 3}}, {7, {2, 3, 2}}, {8, {2, 3, 3}}, 
  {7, {3, 1, 3}}, {7, {3, 2, 2}}, {8, {3, 2, 3}}, {7, {3, 3, 1}}, 
  {8, {3, 3, 2}}, {9, {3, 3, 3}}}} 

f1[Plus, Apply[And] @* OddQ @* List, {i, 3}, {j, 3}, {k, 3}] 

{{{3, {1, 1, 1}}, {5, {1, 1, 3}}, {5, {1, 3, 1}}, {7, {1, 3, 3}},
 {5, {3, 1, 1}}, {7, {3, 1, 3}}, {7, {3, 3, 1}}, {9, {3, 3, 3}}}} 

f1[FOO, OddQ @* Times, {i, 3}, {j, 3}, {k, 3}] 

{{{FOO[1, 1, 1], {1, 1, 1}}, {FOO[1, 1, 3], {1, 1, 3}}, 
 {FOO[1, 3, 1], {1, 3, 1}}, {FOO[1, 3, 3], {1, 3, 3}}, 
 {FOO[3, 1, 1], {3, 1, 1}}, {FOO[3, 1, 3], {3, 1, 3}},
 {FOO[3, 3, 1], {3, 3, 1}}, {FOO[3, 3, 3], {3, 3, 3}}}} 

Answer 2

I think a slightly modified version of Leonid's tableGenAlt should do what you need.

ClearAll[tableGenAlt];
SetAttributes[tableGenAlt, HoldAll];
tableGenAlt[expr_, test_, iter__List] := 
  Module[{sowTag, v = Hold[iter][[All, 1]]},
   First[Last@Reap[
      Do[If[test[#], Sow[{#, {ReleaseHold@v}}, sowTag]] &[expr], iter], 
        sowTag], {}]];

tableGenAlt[i + j + k, GreaterThan[6], {i, 3}, {j, 3}, {k, 3}]
(* {{7, {1, 3, 3}}, {7, {2, 2, 3}}, {7, {2, 3, 2}}, {8, {2, 3, 
   3}}, {7, {3, 1, 3}}, {7, {3, 2, 2}}, {8, {3, 2, 3}}, {7, {3, 3, 
   1}}, {8, {3, 3, 2}}, {9, {3, 3, 3}}} *)

Answer 3

By choosing the indices right, you can get this using a single Table:

Flatten[Table[{i + j + k, {i, j, k}}, {i, 3}, {j, 4 - i, 3}, {k, 
   7 - i - j, 3}], 2]

This gives:

{{7, {1, 3, 3}}, {7, {2, 2, 3}}, {7, {2, 3, 2}}, {8, {2, 3, 
   3}}, {7, {3, 1, 3}}, {7, {3, 2, 2}}, {8, {3, 2, 3}}, {7, {3, 3, 
   1}}, {8, {3, 3, 2}}, {9, {3, 3, 3}}}