How to derive large Tuples (25^25, 50^50,100^100) under certain condition

Question

My problem is that computer has no sufficient memory to calculate tuples of my list. A simple example can be given as follows:

e1={{{0,0}},{{0,0},{2,1}},{{0,0},{3,1},{3,2}},{{0,0},{4,1},{4,2},{4,3}},{{0,0}}};

What I want to do is to pick all tuples of e1 satisfying the condition that each tuple does not contain two or more duplicated number except 0. For example, one tuple

{{0,0},{2,1},{0,0},{4,1},{0,0}}

will not be picked because we have two 1.

My current code processes such problem into two steps:

1. Pick all possibilities of tuples of list. (Got the problem with insufficient memory because of the large tuples 25^25, 50^50, or 100^100)

2. Delete all tuples which do not satisfy our condition.

Since I got stuck at first step, I am thinking about to combine these two steps together to solve insufficient memory problem.

My code:

Tall = Tuples[e1];
Tallnew = {};
For[i = 1, i < Length[Tall] + 1, i++,
  b = DeleteDuplicates@Cases[Subsets[Flatten[Tall[[i]]], {2}], {c_, c_}][[;; , 1]];
  If[b === {} || b == {0}, AppendTo[Tallnew, Tall[[i]]]]
 ]

I would be very appreciated that If you would like to give some suggestions. Thank you very much.

Answer 1

Here's a recursive function that hopefully achieves what you want. It uses no Tuples or Subsets so it shouldn't be too bad on the memory. I hope your valid tuples are extremely uncommon, because even $25^{25}$ is a ridiculously huge number.

ClearAll@findTuples;
findTuples[e_] := findTuples[e, {}];
findTuples[e_ /; Length[e] == 1, v_] := List /@ First@e;
findTuples[e_, verboten_] := Module[{r, v},
   Flatten[Function[f,
      v = Cases[Union[verboten, Flatten@f], Except[0]];
      r = Fold[DeleteCases[#1, {_?IntegerQ ..., #2, _?IntegerQ ...}, 
          Infinity] &, Rest@e, v];
      Prepend[#, f] & /@ findTuples[r, v]
      ] /@ First@e, 1]
   ];

The idea is to maintain a list of forbidden numbers, and use those to filter the list as we go. At each step we pick each member of the first element in turn, use that to filter the rest of the list, then prepend to valid tuples of the filtered rest. If we have reached the end of the list, just give those back in a list.

findTuples[e1] // Column

{{0,0},{0,0},{0,0},{0,0},{0,0}} {{0,0},{0,0},{0,0},{4,1},{0,0}} {{0,0},{0,0},{0,0},{4,2},{0,0}} {{0,0},{0,0},{0,0},{4,3},{0,0}} {{0,0},{0,0},{3,1},{0,0},{0,0}} {{0,0},{0,0},{3,1},{4,2},{0,0}} {{0,0},{0,0},{3,2},{0,0},{0,0}} {{0,0},{0,0},{3,2},{4,1},{0,0}} {{0,0},{2,1},{0,0},{0,0},{0,0}} {{0,0},{2,1},{0,0},{4,3},{0,0}}

---

Here's a slightly faster version.

ClearAll@findTuples;
findTuples[e_] := findTuples[e, {}];
findTuples[e_ /; Length[e] == 1, v_] := List /@ First@e;
findTuples[e_, verboten_] :=
  If[Min[Length /@ e] > 0,
   Module[{r, v, o, s, i},
    o = Ordering[e, All, Length[#1] < Length[#2] &];
    i = InversePermutation@o;
    s = e[[o]];
    #[[i]] & /@ Flatten[Function[f,
        v = Cases[Flatten@f, Except[0]];
        r = Fold[DeleteCases[#1, {#2, _} | {_, #2}, {2}] &, Rest@s, v];
        Prepend[#, f] & /@ findTuples[r, Union[verboten, v]]
        ] /@ First@s, 1]
    ],
   {}];

If there are zero choices somewhere in the rest, it skips that whole branch. As suggested by @anderstood, it sorts by Length at each step, and then unsorts the results at the end. The filtering of forbidden elements has been improved: assuming we are always dealing with pairs of integers, and only filtering on the new forbidden numbers.

BUT it's still going to get slow as the combinations increase. If OP wants to provide sample data, or how it is generated, then maybe it could be tailored to that. I believe you have no hope to filter $100^{100}$ combinations.

Answer 2

My current code for this question is divided into two steps:

Step 1, pick any tuples satisfy the condition that there are no two or more duplicated number except 0.

ClearAll@findTuples;
findTuples[e_] := findTuples[e, {}];
findTuples[e_ /; Length[e] == 1, v_] := List /@ First@e;
findTuples[e_, verboten_] := 
If[Min[Length /@ e] > 0, 
Module[{r, v, o, s, i}, 
o = Ordering[e, All, Length[#1] < Length[#2] &];
i = InversePermutation@o;
s = e[[o]];
#[[i]] & /@ Flatten[Function[f, v = Cases[Flatten@f, Except[0]];
    r = Fold[DeleteCases[#1, {#2, _} | {_, #2}, {2}] &, Rest@s, v];
    Prepend[#, f] & /@ findTuples[r, Union[verboten, v]]] /@ 
   First@s, 1]], {}];

Tallnew = findTuples[e1];

Step 2, calculate the number of remaining tuples and find the max one. Note, the number of a tuple here is the total number of positive integer (>0) in the tuple.

ClearAll[f];
f = Compile[{{vector, _Real, 1}, {bound, _Real}}, 
Module[{t = 0, i = 1, len = Length[vector]}, 
For[i = 1, i <= len, i++, t += Boole[vector[[i]] > bound]]; t], 
CompilationTarget -> "C", "RuntimeOptions" -> "Speed"];

Mnumber = Max[Reap[Do[Sow[f[Flatten[Tallnew[[n]]], 0]], {n, Length[Tallnew]}]][[2]]];

The problem is when I input sublist=30, the computer will spend a very long time to calculate. Now, I am thinking put these two steps into one function. But I am struggling to write the new function. My logic is first to check the first condition in step 1, if it is satisfied, calculate its number (we do not need to store this tuple). If the number is larger than which of any previous tuples, store the number. Otherwise, continue to next tuple.