Generating a large table of values and selecting some of them following some condition

Question

I am working on a problem where I have to generate a table of components while each component of the table has 18 entries. Six of the indices among 18 run from 0 to 1 while the other 12 can take values between 0 to 3. After doing that I have to select some of the entries which follow a certain criterion (sum of all values in each component should be three). I have done this for smaller sized entry tables but for this one Mathematica gives up very fast saying General::nomem: The current computation was aborted because there was insufficient memory available to complete the computation. I don't have a larger memory computer available. Can somebody help me with this please? The commands I am using are:

list = 
  Table[{i, j, k, l, m, n, o, p, q, r, s, u, v, x, y, z, a, b}, 
    {i, 0, 1}, {j, 0, 3}, {k, 0, 3}, {l, 0, 1}, {m, 0, 3}, {n, 0, 3}, {o, 0, 1}, 
    {p, 0, 3}, {q, 0, 3}, {r, 0, 1}, {s, 0, 3}, {u, 0, 3}, {v, 0, 1}, {x, 0, 3}, 
    {y, 0, 3}, {z, 0, 1}, {a, 0, 3}, {b, 0, 3}] // Flatten

list1 = Partition[%, 18];

f1 = Total[#] < 4 &;

f2 = Total[#] > 2 &;

list2 = Select[list1, f1];

list3 = Select[list1, f2];

list4 = Intersection[list2, list3];

Answer 1

I think the comment solution will serve you well:

p1 = Join @@ Permutations /@ IntegerPartitions[3, {18}, Range[0, 3]];
result = Cases[p1, Alternatives @@@ Range[0, {1, 3, 3, 1, 3, 3, 1, 3, 3, 1, 3, 3, 1, 3, 3, 1, 3, 3}]];

Testing this (on my loungebook, so I limited both yours and this to indices to u), yours took ~30 seconds and the initial table took over 50MB on ByteCount, the above finished under timer resolution with under 19KB used... I'd expect 10-20X faster speed on a workstation, same memory needs.

Same result, modulo sort order.

The advantage will of course grow extending the indices to the full set.

Answer 2

I don't know if this will save you sufficient memory, but it will certainly cut down your memory use.

$HistoryLength = 0;
list1 = 
   Flatten[
     Table[{i, j, k, l, m, n, o, p, q, r, s, u, v, x, y, z, a, b}, 
       {i, 0, 1}, {j, 0, 3}, {k, 0, 3}, {l, 0, 1}, {m, 0, 3}, {n, 0, 3}, {o, 0, 1}, 
       {p, 0, 3}, {q, 0, 3}, {r, 0, 1}, {s, 0, 3}, {u, 0, 3}, {v, 0, 1}, {x, 0, 3}, 
       {y, 0, 3}, {z, 0, 1}, {a, 0, 3}, {b, 0,3}], 17];
list2 = Select[list1, 2 < Total[#] < 4 &]

Answer 3

I think this can done as follows:

pol = {1, 3, 3, 1, 3, 3, 1, 3, 3, 1, 3, 3, 1, 3, 3, 1, 3, 3};
ip = Join @@ (Permutations /@ PadRight[IntegerPartitions[3, 3]]);
subs = Subsets[Range[18], {3}];
rl = Flatten[Map[Function[u, Thread[u -> #] & /@ ip], subs], 1];
cand = ReplacePart[ConstantArray[0, 18], #] & /@ rl;
ex = Position[pol, 1]
pck = Pick[cand, Max[Extract[#, ex]] <= 1 & /@ cand];

As I understand this aims to find vectors of length 18 with restrictions described whose sum of components is 3.

cand just finds vectors with elements {0,1,2,3}. pck picks out those that comply with condition {0,1} for positions in ex. There are 5712 cases.

Apologies if I have misunderstood.

A sample (20) is presented below: