0
$\begingroup$

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];
$\endgroup$
  • $\begingroup$ Are you after this: 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}]]; ? $\endgroup$ – ciao Jul 27 '15 at 6:34
3
$\begingroup$

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.

$\endgroup$
1
$\begingroup$

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 &]
$\endgroup$
  • $\begingroup$ That's still going to generate over a billion entries... :-) $\endgroup$ – ciao Jul 27 '15 at 6:41
  • $\begingroup$ @ciao. Yeah. But it's the best I could come with. My system could possibly just handle it, but perhaps not the OP's $\endgroup$ – m_goldberg Jul 27 '15 at 6:43
0
$\begingroup$

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:

enter image description here

$\endgroup$
  • $\begingroup$ Thank you so much all for helping. Especially ubpdqn (last response)! $\endgroup$ – Imran Aug 4 '15 at 23:15

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.