3
$\begingroup$

I am trying to implement the following algorithm into a Mathematica code but I am unsure how to proceed. Let $M$ be a 4x4 symmetric matrix, for example $$M=\begin{pmatrix} 1&1&0&1 \\ 1&0&0&1 \\ 0&0&1&0 \\ 1&1&0&0 \end{pmatrix} $$

  1. Go through the diagonal of the matrix $M$ and find the zero entries $e_{ij}$ first.
  2. In order of appearance, go through the row $i$ corresponding to $e_{ij}$ and find all 1 entries.
  3. Take the first '1' entry in column $k$ and check $e_{kk}$ in the diagonal. If $e_{kk}$=0, then stop and return $k$, else take the second column $l$ ($k$ < $l$) and check $e_{ll}$. If the corresponding diagonal entries in the $i$-th row are all 1, consider the second row and repeat the procedure.

In the example above, the algorithm first returns $M_{2,2}$ and $M_{4,4}$. First, it check the second row and finds $M_{2,1}$=1. It then checks that $M_{1,1}$=0 and thus it ignores it and goes to $M_{2,4}$=1. Then, it sees that $M_{4,4}$=0, thus it returns 4.

Edit: I already solved it and I will add the solution in case anyone is interested:

dzero[x_] := Flatten[Position[Diagonal[x], 0]];
k[x_] := Subsets[dzero[x], {2}]
p[x_] := Extract[k[x], FirstPosition[Extract[x, k[x]], 1]][[
  1]];
pp[x_] := 
 Extract[k[x], FirstPosition[Extract[x, k[x]], 1]][[
  2]];
$\endgroup$

1 Answer 1

3
$\begingroup$

Maybe something like:

ClearAll[f]
f[m_] := Module[{i = 0, 
   p = DeleteDuplicates @ 
     Flatten[PositionIndex[m[[#]]]@ 1 & /@ PositionIndex[Diagonal @ m] @ 0]}, 
  Quiet @ Check[While[0 != m[[#, #]] &@p[[++i]]]; p[[i]], "failed"]]

Examples:

m = {{1, 1, 0, 1}, {1, 0, 0, 1}, {0, 0, 1, 0}, {1, 1, 0, 0}};
MatrixForm @ m

enter image description here

f[m]
 4
m2 = {{1, 1, 0, 1}, {1, 0, 0, 0}, {0, 0, 1, 0}, {1, 1, 0, 0}};
MatrixForm[m2]

enter image description here

f[m2]
2
m3 = {{1, 1, 0, 1}, {1, 0, 0, 0}, {0, 0, 1, 0}, {1, 0, 0, 0}};
MatrixForm[m3]

enter image description here

f[m3]
"failed"

Update: An alternative approach:

ClearAll[f2]
f2[m_] := FirstCase[{a_, b_} /; m[[a, b]] == 1 :> b] @
  DeleteCases[{a_, a_}] @ Tuples[PositionIndex[Diagonal @ m] @ 0, 2]

f2 /@ {m, m2, m3}
 {4, 2, Missing["NotFound"]}
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.