# Writing a circular matrix

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{bmatrix} A & B & \cdots &B\\ B^T & A & \cdots & B\\ \vdots & \vdots & \ddots & \vdots\\ B^T & B^T & \cdots &A \end{bmatrix}.$$

$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?

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]


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

• Re: "for some reason" : (58963) Apr 12, 2015 at 16:23

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


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