How to Flatten Array of Arrays of the highest order in a simple way?

Question

I have a matrix of matrices, given in the following code. I want to flatten the array...

e1[l_] = Table[{KroneckerDelta[l, m]}, {m, 1, 2}];

σ[l_, m_, k_] = e1[l].Transpose[e1[m]]; 
na = 4;
Sigma[l_, m_] := TensorProduct @@ Table[ σ[l, m, k], {k, 1, na}]
Sigma[1, 1] // MatrixForm

I can do this, but if na is very large then this method:

ArrayFlatten[ArrayFlatten[ArrayFlatten[ArrayFlatten[Sigma[1, 1]]]]] // MatrixForm

is not convenient.

Answer 1

I'd use FixedPoint:

FixedPoint[ ArrayFlatten, Sigma[1, 1]]

We have:

ArrayFlatten[ ArrayFlatten[ ArrayFlatten[ ArrayFlatten[ Sigma[1, 1]]]]] ==
FixedPoint[ ArrayFlatten, Sigma[1, 1]]

True

and

FixedPoint[ ArrayFlatten, Sigma[1, 1]] // MatrixForm

Answer 2

Another way is

Flatten[#,{{1,3,5,7},{2,4,6,8}}]&

Or in general

Flatten[#, Transpose@Partition[Range@ArrayDepth[#], 2]] &

Verification:

s = RandomReal[1.0, {2, 2, 2, 2, 2, 2, 2, 2}];

ArrayFlatten@ArrayFlatten@ArrayFlatten@ArrayFlatten[s] == 
    Flatten[#, Transpose@Partition[Range@ArrayDepth[#], 2]] &[s]

True

Answer 3

You can use Fold ignoring the second argument:

Fold[ArrayFlatten[#1] &, Sigma[1, 1], Range @ 4]

Check:

ArrayFlatten[ArrayFlatten[ArrayFlatten[ArrayFlatten[Sigma[1, 1]]]]] == 
 Fold[ArrayFlatten[#1] &, Sigma[1, 1], Range[4]]

True