4
$\begingroup$

I have two square matrices, $A$ and $B$, of the same size, say, of $m \times m$. What I want is to write a programme/function of three variables, $A$, $B$ and $n$, that outputs the $mn \times mn$ matrix which looks like:

\begin{equation} \begin{bmatrix} A & B & \cdots &B\\ B^T & A & \cdots & B\\ \vdots & \vdots & \ddots & \vdots\\ B^T & B^T & \cdots &A \end{bmatrix}. \end{equation}

$B^T$ denotes the transpose of $B$. I want to generate such matrices for different $n$ and work on them.

I was thinking of using Join, but I can not make any better programme than manual list manipulation. Is there a better programme scheme?

$\endgroup$
7
$\begingroup$

You can try ArrayFlatten in such cases

n = 3;
A = Table[Subscript[a, i, j], {i, n}, {j, n}]; MatrixForm[A]
B = Table[Subscript[b, i, j], {i, n}, {j, n}]; MatrixForm[B]
BT = Transpose[B]; MatrixForm[BT]
m = 2;
M = Table[Piecewise[{{A, i == j}, {B, i < j}, {BT, i > j}}], {i, m}, {j,m}] // ArrayFlatten;
MatrixForm[M]
$\endgroup$
7
+500
$\begingroup$

Another way:

Clear[a, b, bt];
m = 2;
n = 3;
sp = Normal@SparseArray[{
     {i_, j_} /; i == j :> a,
     {i_, j_} /; j > i :> b,
     {i_, j_} /; i > j :> bt}, {n*m, n*m}];

Mathematica graphics

And replace the matrix with the numerical values

a0 = RandomInteger[10, {m, m}];
b0 = RandomInteger[10, {m, m}];
bT = Transpose[b0];
sp /. {a -> a0, b -> b0, bt -> bT}

Mathematica graphics

ps. Mathematica will not let me insert the numerical values directly in the sparse matrix for some reason, so had to do it in 2 stages

$\endgroup$
  • 1
    $\begingroup$ Re: "for some reason" : (58963) $\endgroup$ – Mr.Wizard Apr 12 '15 at 16:23
4
$\begingroup$

I may have misunderstood but:

    f[a_, b_, n_] := Module[{lg = Length[a[[1]]], m1, m2, m3},
  m1 = UpperTriangularize[
    ConstantArray[w[b], {n + lg - 1, n + lg - 1}], lg];
  m2 = LowerTriangularize[
    ConstantArray[w[Transpose[b]], {n + lg - 1, n + lg - 1}], -lg];
  m3 = DiagonalMatrix[ConstantArray[w[a], n]]; 
  Plus @@ (ArrayFlatten /@ ({m1, m2, m3} /. {w -> Sequence}))
  ]

Example,

f[{{1, 2}, {3, 4}}, {{5, 6}, {7, 8}}, 5] // MatrixForm

yields:

enter image description here

Just to emphasize the block structure (apologies too lazy to change colour of transposes):

Grid[f[{{1, 2}, {3, 4}}, {{5, 6}, {7, 8}}, 5], 
 Dividers -> {{{True, False}}, {{True, False}}}, 
 Background -> {Purple, None, 
   Thread[Table[{i, i}, {i, 10}]~Join~Table[{i, i + 1}, {i, 1, 9, 2}]~
      Join~Table[{i, i - 1}, {i, 2, 10, 2}] -> Red]}, 
 BaseStyle -> {White, Bold}]

enter image description here

Or 3x3 example:

t1 = {{6, 6, 1}, {0, 3, 7}, {8, 6, 0}}
t2 = {{1, 1, 7}, {2, 4, 5}, {1, 5, 8}}
diag = Thread[
   Join @@ NestList[Map[Function[x, x + {3, 3}], #] &, 
      Tuples[Range[3], 2], 4] -> Red];
Grid[f[t1, t2, 5], 
 Dividers -> {{{True, False, False}}, {{True, False, False}}}, 
 Background -> {Purple, None, diag}, BaseStyle -> {White, Bold}]

enter image description here

Generalizing the visualization:

vis[m_, b_] := Module[{lgt = Length[m[[1]]], dg},
  dg = Thread[
    Join @@ NestList[Map[Function[x, x + {b, b}], #] &, 
       Tuples[Range[b], 2], lgt /b - 1] -> Red];
  Grid[m, 
   Dividers -> {{Prepend[Table[False, {b - 1}], True]}, {Prepend[
       Table[False, {b - 1}], True]}}, 
   Background -> {Purple, None, dg}, BaseStyle -> {White, Bold}]
  ]
gf[a_, b_, n_] := vis[f[a, b, n], Length[a[[1]]]]

enter image description here

$\endgroup$
3
$\begingroup$

Update: Using ToeplitzMatrix with ArrayFlatten:

blockToeplitzF = ArrayFlatten[
    ToeplitzMatrix[{Defer[#], ## & @@ ConstantArray[Transpose[Defer@#2], #3 - 1]},
                   {Defer[#], ## & @@ ConstantArray[Defer[#2], #3 - 1]}] /. 
     Defer -> Identity] &;

Example:

ma = Array[Subscript[a, ##] &, {2, 2}];
mb = Array[Subscript[b, ##] &, {2, 2}];
Row[MatrixForm@blockToeplitzF[ma, mb, #] & /@ {2, 3}]

enter image description here

In version 10, you can use the combination Inactive / Activate instead of Defer.

blockToeplitzF2 = With[{a = #,b = ConstantArray[#2, #3 - 1],
   c = ConstantArray[Transpose@#2, #3 - 1]},
  ArrayFlatten[Activate@
     ToeplitzMatrix[Inactive/@{a, ## & @@ c}, Inactive/@{a, ## & @@ b}]]]&;

  Row[MatrixForm@blockToeplitzF2[ma, mb, #] & /@ {2, 3}]
  (* same output as above *)

Note: A variation of @Nasser's answer using Defer:

saF = ArrayFlatten[Normal[SparseArray[{{i_, j_} /; i == j :> Defer[#],
        {i_, j_} /; j > i :> Defer[#2],
        {i_, j_} /; i > j :> Defer[Transpose@#2]}, {#3, #3}]] /. 
     Defer -> Identity] &;
Row[MatrixForm@saF[ma, mb, #] & /@ {2, 3}]
(* same output as above *)

Original post:

n = 3;
m = 2;
aa = Array[Subscript[a, ##] &, {n, n}];
bb = Array[Subscript[b, ##] &, {n, n}];
bbt = Transpose[bb];
upper = UpperTriangularize[ConstantArray[1, {m, m}], 1];
lower = Transpose@upper;
im = IdentityMatrix[m];

res = Total[MapThread[KroneckerProduct, {{im, upper, lower}, {aa, bb, bbt}}]];
res // MatrixForm 

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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