# How to transform a matrix to upper-triangular with operation- tag elegantly?

### Description:

Recently, I have a thought that writing a function to show the transformation process when a matrix is transformed to upper-triangular.

### My trail

Formatting the result(with the help of Mr.Wizard and Öskå)

augmentedMatrixForm[mat_?MatrixQ] :=
MatrixForm@List@
Grid[
mat, Dividers -> {Length[mat] + 1 -> {Red, Dashed}, False}, Alignment -> Center]


Function LadderMatrixSteps

LadderMatrixSteps[mat_?MatrixQ] /; Equal @@ Dimensions@mat && Det@mat != 0 :=
row = Length@mat;
augmentedMat = Join[mat, IdentityMatrix@Length@mat, 2];
(*=========================================*)
MapAt[
#/ladderStep[i - 1][[(i + 1)/2, (i + 1)/2]] &, ladderStep[i - 1], (i + 1)/2],
MapAt[
List /@ Range[(i + 3)/2, row]]};
(*==============Construct Results=================*)
ladderTransform /@ Range[1, 2 row - 3, 2];
MapAt[
(*============Show Results=================*)
Row[
augmentedMatrixForm /@
Table[ladderStep[i], {i, 0, 2 row - 1}], Style["-\[Rule]", 20, Red]]
]


Test process

testMat= RandomInteger[{1, 10}, {5, 5}];


However, in my function LadderMatrixSteps, I use the construct ladderStep[i] to store the intermidiate results(like array in C). Although it works good, I think it is not suitable in Mathematica .

### Question

1. Is there other elegant method to relize my function LadderMatrixSteps(for example Rule-Based)?

2. Is it possible to add tags between two steps (I just add a decollator "-\[Rule]" in Row)? Namely, shown as below:

Update

Another try

arrow = Graphics[{Arrowheads[Small], Arrow[{{0, 0}, {6, 0}}]}, ImageSize -> {50,10}];

product[m_, n_] := Module[{s, t},
{{Subscript[r, n]/m[[n, n]]}, t = MapAt[#/m[[n, n]] &, m, n],
Table[
s = Subscript[r, i] - t[[i, n]] Subscript[r, n];
t = MapAt[# - t[[i, n]] t[[n]] &, t, i]; s,
{i, n + 1, Length[m]}], t}
]

rowReduce[m_] := Module[{n = Length[m], mat, prt, rst},
mat = {{}, Join[m, IdentityMatrix@n, 2]};
rst = Flatten[FoldList[product[#1[[-1]], #2] &, mat, Range[n]], 1];
prt = Partition[Drop[Rest@rst, -3], 2];
Transpose[{
augmentedMatrixForm /@ Transpose[prt][[1]],
Overscript[arrow, Grid@Map[List, #]] & /@ Transpose[prt][[2]]
}] // Grid // Print;
rst[[-3]] // augmentedMatrixForm
]


The result is same with original code.

rowReduce[RandomInteger[{1, 10}, {3, 3}]]


Origin

This is my try.

divMat[m_, n_, a_] := MapAt[#/a &, m, n]
redMat[m_, n_] := Join[m[[1 ;; n]],
Table[m[[i]] - m[[i, n]] m[[n]], {i, n + 1, Length[m]}]]
makeDivTag[n_, a_] :=
Overscript["--->", Grid[{{"\[Times]", Subscript[r, n]/a}}]]
makeRedTag[m_, n_] := Overscript["--->",
Grid[Table[{Subscript[r, i] - m[[i, n]] Subscript[r, n]}, {i, n + 1,
Length[m]}]]]

rowReduce[mat_] := Module[
{m = Join[mat, IdentityMatrix@Length@mat, 2], l, a},
l = {augmentedMatrixForm[m]};
Do[a = m[[i, i]];
{AppendTo[l, makeDivTag[i, a]]; m = divMat[m, i, a];
AppendTo[l, augmentedMatrixForm[m]],
AppendTo[l, makeRedTag[m, i]]; m = redMat[m, i];
AppendTo[l, augmentedMatrixForm[m]]},
{i, Length[m]}];
Partition[Drop[l, -2], 2] // Grid // TraditionalForm // Print;
augmentedMatrixForm[m]
]

rowReduce[testMat]


Table and MapAt with Span can reduce the code to almost two lines:

n = 3;
A = RandomInteger[10, {n, n}];
MatrixForm[A]


LU = Join[A, IdentityMatrix[n], 2];
res = Table[{LU = MapAt[#/LU[[k, k]] &, LU, k],
LU = MapAt[# - #[[k]] LU[[k]] &, LU, k + 1 ;;]}, {k, n}];
Map[augmentedMatrixForm, res, {2}] // Grid


With "tags" it is a bit longer

LU = Join[A, IdentityMatrix[n], 2];
res = Join @@ Table[{If[k > 1, {(Subscript[r, #] -> Subscript[r, #] -
Subscript[r, k - 1] LU[[#, k - 1]]) & /@ Range[k, n],
LU = MapAt[# - #[[k - 1]] LU[[k - 1]] &, LU, k ;;]}, {"", LU}],
{Subscript[r, k] -> Subscript[r, k]/LU[[k, k]],
LU = MapAt[#/LU[[k, k]] &, LU, k]}}, {k, n}];
MapAt[TableForm, MapAt[augmentedMatrixForm, res, {All, 2}], {All, 1}] // Grid


P.S. I didn't check the degeneracy of the matrix.

• @Tangshutao Which version do you use? This syntax was added in recent versions of Mathematica. You can use Range[k+1,n] instead of k+1;;. Sep 28, 2014 at 13:26