Select a subset in the bit-strings with even 1s overlapped - thank you

Question

Model 1

Consider the permutation list of 4-bit-strings:

list = Permutations[{0, 0, 1, 1}, {4}]

which outputs:

{{0, 0, 1, 1}, {0, 1, 0, 1}, {0, 1, 1, 0}, {1, 0, 0, 1}, {1, 0, 1, 0}, {1, 1, 0, 0}}.

We like to select a subset among these six 4-bit-strings such that any of the two among the subset, will have an even number of bit 1 overlaps.

One way to proceed is to define

overlap[x_, y_] = x.y;

So when there is an even number of 1s overlap among x and y from the list, then

EvenQ[overlap[x, y]] outputs True.

What missing now is the last step, we need to ensure the enumeration, from the first {0, 0, 1, 1} to the last {1, 1, 0, 0} in the list, picking up any two, say x and y, they further satisfy the constraint EvenQ[overlap[x, y]] outputs True.

We expect the answer is {{0, 0, 1, 1}, {1, 1, 0, 0}}.

But a possible form to achieve this last step is something like using

Select, EvenQ, overlap[#, #]] &

But something like this fail:

subset = Select[list, EvenQ[overlap[#, #]] &]

What will be the correct way to select the subset (each with even 1s overlapped in the same position in the bit-string)?

I have some laborious way to do it by enumeration, but I like to hear experts shortcut to do it. Thank you!

Model 2

I like to elaborate another toy model to test the wonderful answer @lericr. lericr's answer got it right for 4-bit string; but not more general example.

Consider the permutation list of 8-bit-strings:

 list = Permutations[{ 1, 1, 1, 1, 0, 0, 0, 0}, {8}] 

which outputs:

{{1, 1, 1, 1, 0, 0, 0, 0}, {1, 1, 1, 0, 1, 0, 0, 0}, {1, 1, 1, 0, 0, 1, 0, 0}, {1, 1, 1, 0, 0, 0, 1, 0}, {1, 1, 1, 0, 0, 0, 0, 1}, {1, 1, 0, 1, 1, 0, 0, 0}, {1, 1, 0, 1, 0, 1, 0, 0}, {1, 1, 0, 1, 0, 0, 1, 0}, {1, 1, 0, 1, 0, 0, 0, 1}, {1, 1, 0, 0, 1, 1, 0, 0}, {1, 1, 0, 0, 1, 0, 1, 0}, {1, 1, 0, 0, 1, 0, 0, 1}, {1, 1, 0, 0, 0, 1, 1, 0}, {1, 1, 0, 0, 0, 1, 0, 1}, {1, 1, 0, 0, 0, 0, 1, 1}, {1, 0, 1, 1, 1, 0, 0, 0}, {1, 0, 1, 1, 0, 1, 0, 0}, {1, 0, 1, 1, 0, 0, 1, 0}, {1, 0, 1, 1, 0, 0, 0, 1}, {1, 0, 1, 0, 1, 1, 0, 0}, {1, 0, 1, 0, 1, 0, 1, 0}, {1, 0, 1, 0, 1, 0, 0, 1}, {1, 0, 1, 0, 0, 1, 1, 0}, {1, 0, 1, 0, 0, 1, 0, 1}, {1, 0, 1, 0, 0, 0, 1, 1}, {1, 0, 0, 1, 1, 1, 0, 0}, {1, 0, 0, 1, 1, 0, 1, 0}, {1, 0, 0, 1, 1, 0, 0, 1}, {1, 0, 0, 1, 0, 1, 1, 0}, {1, 0, 0, 1, 0, 1, 0, 1}, {1, 0, 0, 1, 0, 0, 1, 1}, {1, 0, 0, 0, 1, 1, 1, 0}, {1, 0, 0, 0, 1, 1, 0, 1}, {1, 0, 0, 0, 1, 0, 1, 1}, {1, 0, 0, 0, 0, 1, 1, 1}, {0, 1, 1, 1, 1, 0, 0, 0}, {0, 1, 1, 1, 0, 1, 0, 0}, {0, 1, 1, 1, 0, 0, 1, 0}, {0, 1, 1, 1, 0, 0, 0, 1}, {0, 1, 1, 0, 1, 1, 0, 0}, {0, 1, 1, 0, 1, 0, 1, 0}, {0, 1, 1, 0, 1, 0, 0, 1}, {0, 1, 1, 0, 0, 1, 1, 0}, {0, 1, 1, 0, 0, 1, 0, 1}, {0, 1, 1, 0, 0, 0, 1, 1}, {0, 1, 0, 1, 1, 1, 0, 0}, {0, 1, 0, 1, 1, 0, 1, 0}, {0, 1, 0, 1, 1, 0, 0, 1}, {0, 1, 0, 1, 0, 1, 1, 0}, {0, 1, 0, 1, 0, 1, 0, 1}, {0, 1, 0, 1, 0, 0, 1, 1}, {0, 1, 0, 0, 1, 1, 1, 0}, {0, 1, 0, 0, 1, 1, 0, 1}, {0, 1, 0, 0, 1, 0, 1, 1}, {0, 1, 0, 0, 0, 1, 1, 1}, {0, 0, 1, 1, 1, 1, 0, 0}, {0, 0, 1, 1, 1, 0, 1, 0}, {0, 0, 1, 1, 1, 0, 0, 1}, {0, 0, 1, 1, 0, 1, 1, 0}, {0, 0, 1, 1, 0, 1, 0, 1}, {0, 0, 1, 1, 0, 0, 1, 1}, {0, 0, 1, 0, 1, 1, 1, 0}, {0, 0, 1, 0, 1, 1, 0, 1}, {0, 0, 1, 0, 1, 0, 1, 1}, {0, 0, 1, 0, 0, 1, 1, 1}, {0, 0, 0, 1, 1, 1, 1, 0}, {0, 0, 0, 1, 1, 1, 0, 1}, {0, 0, 0, 1, 1, 0, 1, 1}, {0, 0, 0, 1, 0, 1, 1, 1}, {0, 0, 0, 0, 1, 1, 1, 1}}

Then we expect to Select a subset so the subset contains at least only 14 out of the original 70 of 8-bit-strings. I expect a Correct Answer like this:

Correct Answer:: {{1, 1, 1, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 1, 1, 1, 1}, {1, 1, 0, 0, 1, 1, 0, 0}, {1, 1, 0, 0, 0, 0, 1, 1}, {0, 0, 1, 1, 1, 1, 0, 0}, {0, 0, 1, 1, 0, 0, 1, 1}, {1, 0, 1, 0, 1, 0, 1, 0}, {1, 0, 1, 0, 0, 1, 0, 1}, {0, 1, 0, 1, 1, 0, 1, 0}, {0, 1, 0, 1, 0, 1, 0, 1}, {1, 0, 0, 1, 1, 0, 0, 1}, {1, 0, 0, 1, 0, 1, 1, 0}, {0, 1, 1, 0, 1, 0, 0, 1}, {0, 1, 1, 0, 0, 1, 1, 0}}.

Note that the lericr's EvenNeighbors[list[[1]], list] somehow fails but produces a subset of 38 such 8-bit-strings --- among many of them have an odd number of 1s overlapped. For your eys, we find

EvenNeighbors[target_, list_] := Select[list, EvenQ[overlap[target, #]] &]
EvenNeighbors[list[[1]], list] 

Wrong Answer: {{1,1,1,1,0,0,0,0},{1,1,0,0,1,1,0,0},{1,1,0,0,1,0,1,0},{1,1,0,0,1,0,0,1},{1,1,0,0,0,1,1,0},{1,1,0,0,0,1,0,1},{1,1,0,0,0,0,1,1},{1,0,1,0,1,1,0,0},{1,0,1,0,1,0,1,0},{1,0,1,0,1,0,0,1},{1,0,1,0,0,1,1,0},{1,0,1,0,0,1,0,1},{1,0,1,0,0,0,1,1},{1,0,0,1,1,1,0,0},{1,0,0,1,1,0,1,0},{1,0,0,1,1,0,0,1},{1,0,0,1,0,1,1,0},{1,0,0,1,0,1,0,1},{1,0,0,1,0,0,1,1},{0,1,1,0,1,1,0,0},{0,1,1,0,1,0,1,0},{0,1,1,0,1,0,0,1},{0,1,1,0,0,1,1,0},{0,1,1,0,0,1,0,1},{0,1,1,0,0,0,1,1},{0,1,0,1,1,1,0,0},{0,1,0,1,1,0,1,0},{0,1,0,1,1,0,0,1},{0,1,0,1,0,1,1,0},{0,1,0,1,0,1,0,1},{0,1,0,1,0,0,1,1},{0,0,1,1,1,1,0,0},{0,0,1,1,1,0,1,0},{0,0,1,1,1,0,0,1},{0,0,1,1,0,1,1,0},{0,0,1,1,0,1,0,1},{0,0,1,1,0,0,1,1},{0,0,0,0,1,1,1,1}}

Answer 1

list = Permutations[{0, 0, 1, 1}, {4}]
(*    {{0, 0, 1, 1}, {0, 1, 0, 1}, {0, 1, 1, 0},
       {1, 0, 0, 1}, {1, 0, 1, 0}, {1, 1, 0, 0}}    *)

Compute which members are connected by having an even-valued overlap:

m = Outer[Boole[EvenQ[#1 . #2]] &, list, list, 1]
(*    {{1, 0, 0, 0, 0, 1},
       {0, 1, 0, 0, 1, 0},
       {0, 0, 1, 1, 0, 0},
       {0, 0, 1, 1, 0, 0},
       {0, 1, 0, 0, 1, 0},
       {1, 0, 0, 0, 0, 1}}    *)

This represents a graph:

g = AdjacencyGraph[m]

Find all cliques of this graph:

c = FindClique[g, ∞, All]
(*    {{3, 4}, {2, 5}, {1, 6}}    *)

Look at the elements of the first clique, as an example:

list[[c[[1]]]]
(*    {{0, 1, 1, 0}, {1, 0, 0, 1}}    *)

model 2

list = Permutations[{1, 1, 1, 1, 0, 0, 0, 0}, {8}];
m = Outer[Boole[EvenQ[#1 . #2]] &, list, list, 1];
g = AdjacencyGraph[m];
c = FindClique[g, ∞, All];

For example, the first clique:

list[[c[[1]]]]
(*    {{1, 1, 1, 0, 0, 0, 0, 1},
       {1, 1, 0, 1, 0, 0, 1, 0},
       {1, 1, 0, 0, 1, 1, 0, 0},
       {1, 0, 1, 1, 0, 1, 0, 0},
       {1, 0, 1, 0, 1, 0, 1, 0},
       {1, 0, 0, 1, 1, 0, 0, 1},
       {1, 0, 0, 0, 0, 1, 1, 1},
       {0, 1, 1, 1, 1, 0, 0, 0},
       {0, 1, 1, 0, 0, 1, 1, 0},
       {0, 1, 0, 1, 0, 1, 0, 1},
       {0, 1, 0, 0, 1, 0, 1, 1},
       {0, 0, 1, 1, 0, 0, 1, 1},
       {0, 0, 1, 0, 1, 1, 0, 1},
       {0, 0, 0, 1, 1, 1, 1, 0}}    *)

Outer[Dot, %, %, 1] // MatrixForm

$$ \left( \begin{array}{cccccccccccccc} 4 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 0 \\ 2 & 4 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 0 & 2 \\ 2 & 2 & 4 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 0 & 2 & 2 \\ 2 & 2 & 2 & 4 & 2 & 2 & 2 & 2 & 2 & 2 & 0 & 2 & 2 & 2 \\ 2 & 2 & 2 & 2 & 4 & 2 & 2 & 2 & 2 & 0 & 2 & 2 & 2 & 2 \\ 2 & 2 & 2 & 2 & 2 & 4 & 2 & 2 & 0 & 2 & 2 & 2 & 2 & 2 \\ 2 & 2 & 2 & 2 & 2 & 2 & 4 & 0 & 2 & 2 & 2 & 2 & 2 & 2 \\ 2 & 2 & 2 & 2 & 2 & 2 & 0 & 4 & 2 & 2 & 2 & 2 & 2 & 2 \\ 2 & 2 & 2 & 2 & 2 & 0 & 2 & 2 & 4 & 2 & 2 & 2 & 2 & 2 \\ 2 & 2 & 2 & 2 & 0 & 2 & 2 & 2 & 2 & 4 & 2 & 2 & 2 & 2 \\ 2 & 2 & 2 & 0 & 2 & 2 & 2 & 2 & 2 & 2 & 4 & 2 & 2 & 2 \\ 2 & 2 & 0 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 4 & 2 & 2 \\ 2 & 0 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 4 & 2 \\ 0 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 2 & 4 \\ \end{array} \right) $$

Answer 2

If you want to find all pairs that have even overlap:

Select[Tuples[list, 2], EvenQ@*Apply[overlap]]

But you said

We expect the answer is {{0, 0, 1, 1}, {1, 1, 0, 0}}

so I'm not sure I understand your question.

Update

Oh, maybe you want to first select an element of list and use that to generate a subset of elements that have even overlap with the given one. Try this:

EvenNeighbors[target_, list_] := Select[list, EvenQ[overlap[target, #]] &]

Demonstration:

EvenNeighbors[list[[1]], list]
(* {{0, 0, 1, 1}, {1, 1, 0, 0}} *)

Update 2

We're looking for a set where every pair of members in the set has even overlap. So, define yet another function:

AppendIfEvenOverlap[neighborhood_, candidate_] :=
  If[
    AllTrue[overlap[candidate, #] & /@ neighborhood, EvenQ], 
    Append[neighborhood, candidate], 
    neighborhood]

The idea here is that given an existing group that satisfies the rule, we'll accept a new candidate if its inclusion still satisfies the rule. This function does no checking around whether the given neighborhood does indeed satisfy the rule, nor does it prevent a result with duplicates. You'd need to apply it so that it works as desired, which in your specific case could be something like this:

Fold[AppendIfEvenOverlap, {list[[1]]}, Rest@list]

assuming that list[[1]] was your desired generator/seed. If you want some other generator, then you'll probably want something like this:

Fold[AppendIfEvenOverlap, {list[[3]]}, DeleteCases[list, list[[3]]]]

Alternatively you could add in the pre-condition check and use Union to avoid duplications.