Question

我正在开发一个 Mathematica 程序来构造满足指定属性的酉矩阵。为了完成这个构造，我需要找到一行 0 和一列 0 的交点，并在那里放置一个 1。有没有关于如何优雅地做到这一点的想法？

例如，考虑

{{0,0,-(1/Sqrt[2]),1/Sqrt[2]},{0,0,1/Sqrt[2],1/Sqrt[2]},{0,0,0,0},{0,0,0,0}}

并使其统一为

{{0,0,-(1/Sqrt[2]),1/Sqrt[2]},{0,0,1/Sqrt[2],1/Sqrt[2]},{1,0,0,0},{0,1,0,0}}

似乎并不唯一。你想要什么，m1或者 m2？ m = {{0, 0, 0, 3}, {0, 0, 0, 0}, {0, 0, 0, 2}, {0, 0, 0, 0}, {0, 0, 0, 0}, {0, 0, 0, 0}}; {(m1 = {{0, 0, 0, 3}, {1, 0, 0, 0}, {0, 0, 0, 2}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 0}}) // MatrixForm , (m2 = {{0, 0, 0, 3}, {0, 0, 0, 0}, {0, 0, 0, 2}, {1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}}) // MatrixForm} —

Accepted Answer

MatrixForm[mat = {
   {0, 0, -(1/Sqrt[2]), 1/Sqrt[2]},
   {0, 0, 1/Sqrt[2], 1/Sqrt[2]},
   {0, 0, 0, 0},
   {0, 0, 0, 0}}]

MapIndexed[(row[First[#2]] = Union[#1] == {0}) &, mat];
MapIndexed[(col[First[#2]] = Union[#1] == {0}) &, Transpose[mat]];
f[r_, c_] := If[row[r] && col[c], Sow[{r, c}]];
pos = Reap[Outer[f, Sequence @@ Range /@ Dimensions[mat]]][[-1, 1]];
MatrixForm[ReplacePart[mat, pos -> 1]]

{{0, 0, -(1/Sqrt[2]), Sqrt[2]}, 
 {0, 0, 1/Sqrt[2], 1/Sqrt[2]}, 
 {1, 1, 0, 0}, 
 {1, 1, 0, 0}}

并非理想的结果

版本 2

MatrixForm[mat = {
   {0, 0, -(1/Sqrt[2]), 1/Sqrt[2]},
   {0, 0, 1/Sqrt[2], 1/Sqrt[2]},
   {0, 0, 0, 0},
   {0, 0, 0, 0}}]

MapIndexed[(row[First[#2]] = Union[#1] == {0}) &, mat];
MapIndexed[(col[First[#2]] = Union[#1] == {0}) &, Transpose[mat]];

f[r_, c_] := If[row[r] && col[c],
   mat = ReplacePart[mat, {r, c} -> 1];
   row[r] = col[c] = False];

Outer[f, Sequence @@ Range /@ Dimensions[mat]];
MatrixForm[mat]

{{0, 0, -(1/Sqrt[2]), Sqrt[2]}, 
 {0, 0, 1/Sqrt[2], 1/Sqrt[2]}, 
 {1, 0, 0, 0}, 
 {0, 1, 0, 0}}

感谢您的贡献。两个版本都有“Set::write: Tag List in {2}[1] is Protected”错误。如果这很重要的话，我正在使用 Mathematica 11.3。您的版本 2 输出正是我所寻找的。如果您能帮助我让它在我的计算机上执行，我将能够研究您的代码是如何工作的。 — 
嗨，也许Clear[f, row, col]在执行代码之前尝试一下。 —

Answer 2

(mat = {{0, 0, -(1/Sqrt[2]), 1/Sqrt[2]}, {0, 0, 1/Sqrt[2], 
     1/Sqrt[2]}, {0, 0, 0, 0}, {0, 0, 0, 0}}) // MatrixForm

$(\begin{array}{cccc} 0 & 0 & - \frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \\ 0 & 0 & \frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \\ 0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 0 \end{array})$ \left(
\begin{array}{cccc}
0 & 0 & -\frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \\
0 & 0 & \frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \\
0 & 0 & 0 & 0 \\
0 & 0 & 0 & 0 \\
\end{array}
\right)

umat[mat_?MatrixQ] := Module[{
   tr = DiscreteDelta @@@ mat
   , tc = DiscreteDelta @@@ Transpose@mat, pr, pc, ml},
  pr = Flatten@Position[tr, 1];
  pc = Flatten@Position[tc, 1];
  ml = Min@(Length /@ {pr, pc});
  idx = Thread[{pr[[1 ;; ml]], pc[[1 ;; ml]]}];
  SubsetMap[# + 1 &, mat, idx]
  ]

umat[mat] // MatrixForm

$(\begin{array}{cccc} 0 & 0 & - \frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \\ 0 & 0 & \frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \\ 1 & 0 & 0 & 0 \\ 0 & 1 & 0 & 0 \end{array})$ \left(
\begin{array}{cccc}
0 & 0 & -\frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \\
0 & 0 & \frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \\
1 & 0 & 0 & 0 \\
0 & 1 & 0 & 0 \\
\end{array}
\right)

感谢您的贡献！但是我正在使用 Mathematica 11.3，它不了解 SubsetMap。您能提供早期版本的定义或替代品吗？ —

Answer 3

mat = {{0, 0, 0}, {0, 2, 2}, {0, 0, 0}}

我们希望在行和列范数为 0 的地方放置 1。换句话说，行范数 + 列范数为 0。然后我们可以使用Unitize将除 0 以外的任何数值替换为 1，并从中减去 1，得到一个矩阵，该矩阵在行和列范数为 0 的地方为 1，在其他地方为 0。然后我们将其添加到原始矩阵中mat：

mat +=  1 - 
  Unitize@Outer[Plus, Norm /@ mat, Norm /@ (mat\[Transpose])]

请注意，这个矩阵不是酉矩阵，所以我猜测这只是制作酉矩阵的更大算法的一部分。

谢谢，你的想法很有启发，但不适用于我的应用程序。我进行了编辑以使我的问题更清楚。 — 
我认为您可能需要重新措辞您的问题，因为与您的起始矩阵相比，您的目标矩阵不再是“找到一行 0 和一列 0 的交点并在那里放置 1”。

您是否想逐行迭代地查找列和行的相交位置，并将第一次出现的零列/零行替换为 1，然后继续检查下一行（而不是一次查找和替换它们）？
\endgroup

– — 
@PhillipDukes 如果在位置 (3, 2) 处添加一个 1，在位置 (4, 1) 处添加另一个 1，它也是一个酉矩阵。我的问题是，为什么不选择这个选项？ — 
@E.Chan-López 是的，通常有很多方法可以通过策略性地放置 1 来完成一个酉矩阵。我真正需要的就是使其成为酉矩阵。 — 
@ydd 您提出的方法“逐行迭代查找列和行的相交位置，并将第一次出现的零列/零行替换为 1，然后继续检查下一行”确实有效。 —

Answer 4

假设我们以递归方式一次“标记”一个交叉点，我们可以执行以下操作：

MarkFirstIntersection[matrix_?MatrixQ] :=
  With[
    {intersection = Flatten[FirstPosition[0] /@ {Total[matrix, {2}], Total[matrix, {1}]}]},
    If[FreeQ[intersection, _Missing], ReplacePart[matrix, intersection -> 1], matrix]];

list = {{0, 0, -(1/Sqrt[2]), 2/Sqrt[2]}, 
        {0, 0, 1/Sqrt[2], 1/Sqrt[2]}, 
        {0, 0, 0, 0}, 
        {0, 0, 0, 0}};

FixedPoint[MarkFirstIntersection, list]
(* {{0, 0, -(1/Sqrt[2]), Sqrt[2]}, 
    {0, 0, 1/Sqrt[2], 1/Sqrt[2]}, 
    {1, 0, 0, 0}, 
    {0, 1, 0, 0}} *)

Answer 5

这种方法更像是蛮力：

(mat = {{0, 0, -(1/Sqrt[2]), 1/Sqrt[2]}, {0, 0, 1/Sqrt[2], 
     1/Sqrt[2]}, {0,0,0, 0}, {0,0, 0, 0}}) // MatrixForm

Clear[unitize]
unitize[m_] := m + SparseArray[
    With[{n = Count[m, ConstantArray[0, Length[m]]]},
          Transpose[{OrderingBy[m, Max@*Abs][[;;n]],
                     OrderingBy[Transpose[m], Max@*Abs][[;;n]]}]
    ] -> 1, Dimensions[m]]
   
unitize[mat] // UnitaryMatrixQ   (* True *)

对各个短语的解释——

Count[m, ConstantArray[0, Length[m]]] 计算矩阵中零行的数量 $m$ m。此计数（示例中为 2）存储在变量中 $n$ n。

OrderingBy[m, Max@*Abs][[;;n]查找第一个行号 $n$ n零行。在示例中，此表达式返回 {3,4}，因为第 3 行和第 4 行全为零。

OrderingBy[Transpose[m], Max@*Abs][[;;n]]查找第一个列号 $n$ n零列。在此示例中，此表达式返回 {1,2}，因为第 1 列和第 2 列全为零。

该With表达式返回 {{3,4}, {1,2}} 的转置，它给出必须更改为 1 的矩阵元素的下标。

SparseArray[{{3,1}, {4,2}} -> 1, Dimensions[m]给出矩阵 $S$ S尺寸相同 $m$ m，并且具有元素 $S_{3 1} = 1$ S_{3\,1} = 1和元素 $S_{4 2} = 1$ S_{4\,2} = 1其他地方为零。

将稀疏数组添加到原始数组中可得到完整的酉矩阵。

列表操作 – 有什么优雅的方法来找到矩阵中一行 0 和一列 0 的交点？ – Mathematica

5 个回答
5

列表操作 – 有什么优雅的方法来找到矩阵中一行 0 和一列 0 的交点？ – Mathematica

5 个回答 5

5 个回答
5