Writing a circular matrix

Question

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?

Answer 1

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]

Answer 2

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}];

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}

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

Answer 3

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:

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}]

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}]

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]]]]

Answer 4

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}]

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