Improving code for comparing and modifying nested matrices

Question

I have a matrix such as:

 tT = {{a, b, c}, {d, e, f}, {g, h, i}};
 a = {{0, 0, 1}, {0, 1, 0}, {1, 0, 0}};
 b = {{1, 0, 0}, {0, 0, 0}, {0, 1, 0}};
 c = {{0, 0, 0}, {1, 0, 1}, {0, 0, 0}};
 d = {{1, 0, 0}, {0, 1, 0}, {0, 1, 0}};
 e = {{0, 1, 0}, {1, 0, 0}, {1, 0, 0}};
 f = {{0, 1, 0}, {1, 0, 0}, {0, 0, 1}};
 g = {{1, 0, 0}, {0, 0, 0}, {0, 0, 1}};
 h = {{0, 0, 0}, {0, 1, 0}, {0, 0, 0}};
 i = {{1, 0, 0}, {0, 0, 0}, {1, 0, 0}};

That the picture of matrix is same as:

In the first step, I want to compare elements of tT11 with the elements of tT12, also compare between elements of tT11 with the elements of tT13. Moreover, compare between elements of tT12 with the elements of tT13. After that tT21 with tT22 and tT23 and so on.

If at least one of the corresponding elements of tT11 and tT12 are simultaneously equal to 1, I want to put a zero instead for all elements in tT12. Also, I want to make the same comparison, between elements of tT11 with the elements of tT13 with the same condition. (moreover, tT12 and tT13). Also the corresponding element in other rows. I write below line:

Do[
If[tT[[r, n, k, q]] == tT[[r, m, k, q]]==1,
    Do[tT[[r, m, x, y]] = 0,{x,1,3},{y,1,3}]],
    {r, 1, 3}, {n, 1, 2}, {k, 1, 3}, {q, 1, 3}, {m, n + 1, 3}]

Actually, my desire is to get the result that I bring it below: I am going to generalize this goal to a much larger matrix and this matrix (tT 3*3) is just an example. How can I modify above written process (code) for more efficiency. How can I replace other commands instead of two Do loops. My desired result is:

Thank you so much for your attention.

Answer 1

Pattern matching approach:

Clear[replaceWithZero]
replaceWithZero[l_List] := 
  With[{allZero = ConstantArray[0, {3, 3}]}, 
   l //. {a___, x_, b___, y_, c___} /; 
      x != allZero && y != allZero && MemberQ[x + y, 2, {2}] :> {a, x, b, allZero, c}];

replaceWithZero /@ tT // MatrixForm

---

Update: scaling this function up to take matrices of any size:

Clear[compareWithin]
compareWithin[mat_List] := Module[{replaceWithZero, innerDimension},
  innerDimension = Take[Dimensions[mat], -2];
  replaceWithZero[l_List] := 
   With[{allZero = ConstantArray[0, innerDimension]}, 
    l //. {a___, x_, b___, y_, c___} /; 
       x != allZero && y != allZero && MemberQ[x + y, 2, {2}] :> {a, x, b, allZero, c}];
  replaceWithZero /@ mat]

With[{mat = RandomInteger[1, {5, 5, 3, 2}]}, 
  MatrixForm /@ {mat, 
    compareWithin[mat] /. 
     x_List /; MatchQ[Flatten@x, {0 ..}] :> 
      Map[Style[#, Red] &, x, {2}]}] // Row

Answer 2

I think I have a no-loops approach to your problem. First, I am using the fact that you only want to compare tT11 with tT12 and tT13, not with any of the matrices on the other rows of the super matrix. So create a function that operates on a single list of matrices, and then Map that function onto your matrix of matrices, tT.

myfun[a : {__?MatrixQ}] /; Length[a] > 1 &&  (SameQ @@ Dimensions /@ a) :=
 With[{len = Length[First[a]], 
   places = Last /@ Subsets[Range[Length[a]], {2}], 
   maxes = Max /@ Plus @@@ Subsets[a, {2}]}, 
  MapIndexed[
   If[Max[Pick[maxes, places, First@#2]] > 1, 
     ConstantArray[0, {len, len}], #1] &, a]]

myfun /@ tT // MatrixForm

The rationale of my approach is that if you want to replace the submatrix depending on whether any of its elements is a 1 that matches up with a 1 in the earlier submatrix. In other words, if any of the elements of the element-by-element sum of the two matrices is greater than 1. Since Max is Listable, you can test whether the Max of the sum of the two matrices exceeds 1. If it is, you then need to work out which submatrix to zero out, which can be worked out as the second element of the corresponding Subset of a simple range or integers. If the sum of any of the subsets where the second element is the matrix of interest (determined using Pick) has a maximum element above 1, then zero out the matrix.

This function should work for any number of matrices in each row of the super matrix, and for any dimension of the submatrices, as long as all the matrices in each row have the same dimensions. I don't think the submatrices even need to be square.

Answer 3

The 'Do' works correctly but unfortunately, '1' is missed in the first of that:

Do[
       If[tT[[r, n, k, q]] == tT[[r, m, k, q]]==1,
             Do[tT[[r, m, x, y]] = 0,
             {x,1,3},{y,1,3}]],
{r, 1, 3}, {n, 1, 2}, {k, 1, 3}, {q, 1, 3}, {m, n + 1, 3}]

Although, as I know, it is not so optimum code. I wish to eliminate 'Do' in 'Do'.