Connected Magic Squares (Part 1)

• part 1: naive brute force exhaustive search
• part 2: smarter exhaustive search
• part 3: inductive graphs
• part 4: connected magic squares
• part 5: experiments

I found this problem on one of my Mastodon feeds:

Imagine a 6 by 6 grid of squares, that can either be black or white.

It has to fulfill the following properties:
1. Each row and column needs to have 3 white and 3 black squares.
2. All black squares have to be orthogonally connected.

Prove that such a grid cannot exist.

Note: in our digital representation black squares are ones and white squares are zeros.

The first property makes the grid a weak magic square Weak in the sense that only rows and columns but not diagonals have to have the same sum. with values in $\mathbb{Z}_2$. There is tons of material on magic squares so there is plenty of arsenal to attack this problem from that end. The second property is more confounding. I don’t have a good handle on how it relates to the first property, how it might conflict with magic squares. I first thought that maybe orthogonal connectedness disrupts symmetries coming from magic squares. But there are non-symmetric magic squares.

Anyways, to explore this further I decided we need brute-force computer help: functions that search for orthogonally connected magic squares. Is it always impossible ? Does it depend that the grid size is even or odd ? Do the number of ones in each row/column matter or just that they’re the same ?

Initially I wanted to implement these functions in Mathematica because it has some nice plotting built in like MatrixPlot. But honestly, coding in the Wolfram language feels awkward to me. So I decided on Haskell instead.

Let’s dive into the implementation. First we want a function that checks that a given square matrix is a magic square. We assume that the matrix is given as a list of rows. Finding the sum of each row in matrix m is easy:

map (foldr (+) 0) m

For columns we could use the same function applied to the transpose of m. But we need a function that transposes a matrix. If our matrix is given as a list of rows, then the first row of the transpose is made from the first element of each row of the original matrix. The subsequent rows of the transpose are similarly done recursively by transposing a new matrix with rows formed from the original rows but without their first element. It sounds like we need to collect the first element of each row and also collect the rows without their first element.

In Haskell, when I hear “collect”, I think “foldr” 🙂. I need a folding function that collects both head of rows and tails of rows. We can put head and tail conveniently into a tuple. Let’s call the function splitter and we have:

splitter :: [a] -> ([a], [[a]]) -> ([a], [[a]])
splitter [] r = r
splitter (x:xs) (ys, tys) = (x:ys, xs: tys)

Then the function transposeMatrix becomes:

transposeMatrix :: [[a]] -> [[a]]
transposeMatrix m | length (head m) == 0 = []
transposeMatrix m = fs : (transposeMatrix ts)
    where (fs, ts) = foldr splitter ([], []) m

Let’s also define a convenience function allTrue that checks that all elements of a list satisfy a boolean condition:

allTrue :: (a -> Bool) -> [a] -> Bool
allTrue f xs = foldr (&&) True (map f xs)

With these functions at hand we can define a function isMagic that checks if a matrix is a magic square:

isMagic :: (Num a, Eq a) => [[a]] -> Bool
isMagic m = (allTrue equalToTarget rowsums) && (allTrue equalToTarget columnsums)
    where 
        tm = transposeMatrix m
        row = head m
        sumrow = foldr (+) 0
        target =  sumrow row
        rowsums = map sumrow m
        columnsums = map sumrow tm
        equalToTarget = (==) target

Before we tackle the connectedness, let’s think about the brute force approach here. We need a way to generate square matrices of size $n$ in $\mathbb{Z}_2$. There are $2^{n^2}$ such matrices so a simple way would be to consider an integer in the range $[0, 2^{n^2})$ and use its binary digits as matrix elements. We need a function that takes an integer and gives us its binary digits, padded with leading zeros as needed.

binaryDigits' :: Int -> [Int]
binaryDigits' 0 = [0]
binaryDigits' x = r : (binaryDigits' y)
   where 
      y = div x 2
      r = mod x 2

binaryDigits :: Int -> [Int]
binaryDigits xs = (tail . reverse) (binaryDigits' xs)

padDigits' :: Int -> [Int] -> [Int]
padDigits' n xs | n <= 0 = xs
padDigits' n xs = 0 : (padDigits' (n-1) xs)

padDigitsTo :: Int -> [Int] -> [Int]
padDigitsTo n xs = padDigits' (n - (length xs)) xs

We also need a function that splits a list of digits into rows:

splitIntoRows :: Int -> [a] -> [[a]]
splitIntoRows _ [] = []
splitIntoRows n xs = (take n xs) : (splitIntoRows n (drop n xs))

Using binaryDigits, padDigitsTo and splitIntoRows we can write a function that generates a matrix:

squareMatrixFrom :: Int -> Int -> [[Int]]
squareMatrixFrom size n = splitIntoRows size paddedDigits
   where
      digits = binaryDigits n
      paddedDigits = padDigitsTo (size * size) digits

We write a function that looks for all magic squares of a given size and a given number of ones in each row and column:

puzzleFilter :: Int -> Int -> Int -> Maybe [[Int]]
puzzleFilter size numOnes n = if (target == firstrowsum) && (isMagic m) then Just m else Nothing
    where
      m = squareMatrixFrom size n
      target = numOnes
      firstrowsum = foldr (+) 0 (head m)

puzzleExamples :: Int -> Int -> [[[Int]]]
puzzleExamples size numOnes = [m | Just m <- map (puzzleFilter size numOnes) [0..(2^(size * size) - 1)]]

So the two magic squares of size two by two with one one in each row and each column are:

ghci> puzzleExamples 2 1
[[[0,1],[1,0]],[[1,0],[0,1]]]

This post is getting long, so we’ll postpone the connectedness test to the next part and call this the first part in a multipart series. In the next installment we’ll expand the puzzleFilter to also check for connectedness.