How to make an inverse operation to `KroneckerProduct[A, IdentityMatrix[m]]` (simplify matrix)?

Question

The operation KroneckerProduct[A, IdentityMatrix[m]] expands the matrix A in the following way (depending on order of A and m):

$\left( \begin{array}{cc} a & b \\ c & d \\ \end{array} \right)\to \left( \begin{array}{cccc} a & 0 & b & 0 \\ 0 & a & 0 & b \\ c & 0 & d & 0 \\ 0 & c & 0 & d \\ \end{array} \right)$

Is there a way to code the inverse operation that would shrink ("simplify") a matrix this way?

Like

$ \left( \begin{array}{cccc} a & 0 & b & 0 \\ 0 & a & 0 & b \\ c & 0 & d & 0 \\ 0 & c & 0 & d \\ \end{array} \right)\to\left( \begin{array}{cc} a & b \\ c & d \\ \end{array} \right)$

and

$\left( \begin{array}{cccc} a & b & 0 & 0 \\ c & d & 0 & 0 \\ 0 & 0 & a & b \\ 0 & 0 & c & d \\ \end{array} \right)\to \left( \begin{array}{cc} a & b \\ c & d \\ \end{array} \right)$

I also would like if it could (optionally) shrink the matrices using complex numbers this way:

$\left( \begin{array}{cccc} a & b & f & e \\ -b & a & -e & f \\ g & h & d & c \\ -h & g & -c & d \\ \end{array} \right)\to \left( \begin{array}{cc} a+i b & f+i e \\ g+i h & d+i c \\ \end{array} \right)$

Of course, not all matrices would be shrinkable.

Answer 1

You could try

m={{a,0,b,0},{0,a,0,b},{c,0,d,0},{0,c,0,d}};
1/2*TensorContract[ArrayReshape[m,{2,2,2,2}],{2,4}]

or

m={{a,b,0,0},{c,d,0,0},{0,0,a,b},{0,0,c,d}};
1/2*TensorContract[ArrayReshape[m,{2,2,2,2}],{1,3}]

This is related to the partial trace.

Edit. Here is very simple code to automatically decide whether to apply one or the other reduction. It is currently only for a fixed value of dim for simplicity:

dim=2;
traceLeft[m_]:=TensorContract[ArrayReshape[m,{dim,dim,dim,dim}],{2,4}];
traceRight[m_]:=TensorContract[ArrayReshape[m,{dim,dim,dim,dim}],{1,3}];
multipleOfIdentityQ[m_]:=MatchQ[Simplify[m-1/dim*Tr[m]*IdentityMatrix[dim]],{{0...}...}];
undo[m_]:=With[{mL=traceLeft[m],mR=traceRight[m]},
            Which[
               multipleOfIdentityQ[mL],1/dim*mR,
               multipleOfIdentityQ[mR],1/dim*mL,
               True,"Failed"]];

Both

undo[{{a,0,b,0},{0,a,0,b},{c,0,d,0},{0,c,0,d}}]
undo[{{a,b,0,0},{c,d,0,0},{0,0,a,b},{0,0,c,d}}]

return {{a,b},{c,d}}.

Edit 2. Here is another version that can deal with different dimensions. The code it not meant to be bombproof. Please Clear all previous definitions before using this:

traceLeft[m_,{dL_,dR_}]:=TensorContract[ArrayReshape[m,{dL,dR,dL,dR}],{1,3}];
traceRight[m_,{dL_,dR_}]:=TensorContract[ArrayReshape[m,{dL,dR,dL,dR}],{2,4}];
multipleOfIdentityQ[m_]:=And[SquareMatrixQ[m],With[{d=Length[m]},MatchQ[Simplify[m-1/d*Tr[m]*IdentityMatrix[d]],{{0...}...}]]];
undo[m_?SquareMatrixQ,d:{dL_,dR_}]:=With[{mL=traceLeft[m,d],mR=traceRight[m,d]},
               Which[multipleOfIdentityQ[mL],1/dR*mR,
                     multipleOfIdentityQ[mR],1/dL*mL,
                     True,"Failed"]];
undo[m_?SquareMatrixQ]:=With[{d=Length[m]},DeleteCases[Map[undo[m,{#,d/#}]&,DeleteCases[Divisors[d],1|d]],"Failed"]//If[#==={},"Failed",First[#]]&];

I suggest the following examples to see what this does (and what it does not do):

KroneckerProduct[IdentityMatrix[5],Array[a,{4,4}]]//undo
KroneckerProduct[Array[a,{4,4}],IdentityMatrix[7]]//undo
KroneckerProduct[Array[a,{4,4}],Array[b,{2,2}]]//undo
KroneckerProduct[IdentityMatrix[5],IdentityMatrix[4]]//undo

Note in particular that the last example returns neither IdentityMatrix[5] nor IdentityMatrix[4] but

{{1,0},{0,1}}

The specification is simply ambiguous in this sense. If one knows what dimensions one is interested in, one can directly call undo[m_,d:{dL_,dR_}].