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.
- part 1: naive brute force exhaustive search
- part 2: smarter exhaustive search
- part 3: inductive graphs
- part 4: connected magic squares
- part 5: experiments
Note: in our digital representation black squares are ones and white squares are zeros.
This is part 4 of a series of posts about a puzzle I found on Mastodon and which I don’t yet know how to solve. In part 1 we decided to employ a brute force exhaustive search for solutions. In part 2 we improved the performance of the brute force search so it can handle magic squares of size six by six. In part 3 we tackled graph algorithms in a functional programming setting.
We’re now ready to put it all together and run some experiments. What is left to do is to convert a row matrix into an inductive graph and run a DFS over it.
Our strategy will be simple: scan the matrix one row at a time and only look “back” and “up” for connections (so previous row, same column or same row previous column). This ensures that the current node we’re working on and attaching to the graph only references previous nodes already attached to the graph in its adjacency list. That’s it. To get started, we probably need an index-based access to previous matrix values, so it would be useful to have an index-based form of it handy too. The following two functions do the conversion:
listToArray :: [a] -> Array Int a
listToArray xs = array idxs (zip (range idxs) xs)
where
idxs = (0, (length xs - 1))
matrixToArray :: [[a]] -> Array Int (Array Int a)
matrixToArray m = listToArray rs
where
rs = map listToArray m
We also want a function that given a row, column tuple makes an integer out of it. And also its inverse.
rowColumnToNode :: Int -> (Int, Int) -> Int
rowColumnToNode size (row, column) = row * size + column
nodeToRowColumn :: Int -> Int -> (Int, Int)
nodeToRowColumn size node = (div node size, mod node size)
We’ll use a list comprehension for the (row, column) tuples and foldr over it to create the inductive graph. Let’s check the order of our list comprehension bounded variables:
ghci> [(i, j) | i <- [0..2], j <- [0..2]]
[(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)]
Since we’re doing a foldr it would start adding from the back of that list. We already decided to look to previous and I’m lazy, so let’s keep that and adjust the list comprehension:
ghci> [(2 - i, 2 - j) | i <- [0..2], j <- [0..2]]
[(2,2),(2,1),(2,0),(1,2),(1,1),(1,0),(0,2),(0,1),(0,0)]
We still need the function we will foldr with. We’re going to curry the matrix size and indexed array matrix representation into it.
type MatrixArray = Array Int (Array Int Int)
matrixToGraphHelper' :: Int -> MatrixArray -> (Int, Int) -> Graph -> Graph
matrixToGraphHelper' size ma (row, column) g = ctx:g
where
node = rowColumnToNode size (row, column)
orthoNorthNeighbor :: (Int, Int) -> [Int] -> [Int]
orthoNorthNeighbor (r, c) ns = if row > 0 then
if (ma ! (r - 1) ! c) == 1 then
(rowColumnToNode size (r -1, c)):ns
else ns
else ns
orthoWestNeighbor :: (Int, Int) -> [Int] -> [Int]
orthoWestNeighbor (r, c) ns = if c > 0 then
if (ma ! r ! (c - 1)) == 1 then
rowColumnToNode size (r, (c-1)):ns
else ns
else ns
adj = orthoNorthNeighbor (row, column) (orthoWestNeighbor (row, column) [])
ctx = (node, adj)
matrixToGraphHelper :: Int -> MatrixArray -> (Int, Int) -> Graph -> Graph
matrixToGraphHelper size ma (row, column) g =
if (ma ! row ! column) == 1 then matrixToGraphHelper' size ma (row, column) g else g
matrixToGraph :: Int -> MatrixArray -> Graph
matrixToGraph size ma = foldr f [] idxs
where
idxs = [(size - i - 1, size - j - 1) | i <- [0..(size-1)], j <- [0..(size-1)]]
f = matrixToGraphHelper size ma
We are finally ready for a full implementation of solved that also checks for connectedness:
solved :: Int -> State -> Bool
solved k s = (length rows) == size && (allTrue (k ==) cs) && (length vs == length g)
where
(rows, cs) = s
size = length cs
ma = matrixToArray rows
g = matrixToGraph size ma
sn = fst (head g)
vs = dfs [sn] g
Let’s take it for a spin. We already know from the puzzle statement that six by six connected magic square is impossible, so we should get the empty list:
ghci> solutions 3 ([], [0, 0, 0, 0, 0, 0])
[]
what about with more number of ones ? The intuition here is that the chance of being connected increases when there are more ones available in each row and column. Turns out, there are 3108 solutions with four ones. We can plot one example solution:
In the next part we will use this computing machinery to tickle out examples and counter examples and maybe find something to latch onto.
Here is the complete, cleaned up code with all the unused functions from abandoned approaches deleted. You can also find it on this github repo.
module MagicSquare (magicSquares, connectedSquares) where
import Data.Array
import Data.Bits
allTrue :: (a -> Bool) -> [a] -> Bool
allTrue f xs = foldr (&&) True (map f xs)
rowColumnToNode :: Int -> (Int, Int) -> Int
rowColumnToNode rows (row, column) = row * rows + column
nodeToRowColumn :: Int -> Int -> (Int, Int)
nodeToRowColumn rows vertex = (div vertex rows, mod vertex rows)
listToArray :: [a] -> Array Int a
listToArray xs = array idxs (zip (range idxs) xs)
where
idxs = (0, (length xs - 1))
matrixToArray :: [[a]] -> Array Int (Array Int a)
matrixToArray m = listToArray rs
where
rs = map listToArray m
kones :: [Bool] -> Int-> [[Int]]
kones cs 0 = [[0 | _ <- [1..n]]]
where
n = length cs
kones [] _ = []
kones (c:cs) k = if c then
(map (1:) (kones cs (k-1))) ++ (map (0:) (kones cs k))
else
(map (0:) (kones cs k))
type Node = Int
type Adj = [Node]
type Context = (Node, Adj)
type Graph = [Context]
without :: Node -> Adj -> Adj
without _ [] = []
without y (x:xs) = if x == y then xs else x:(without y xs)
findNode :: Node -> Graph -> Maybe (Int, Context)
findNode _ [] = Nothing
findNode u (v:g) = if u == fst v then Just (0, v) else
case (findNode u g) of
Just (n, v) -> Just ((n+1), v)
Nothing -> Nothing
transferEdge :: Context -> (Context, Graph) -> (Context, Graph)
transferEdge (v, onV) ((matched, onMatched), xs) = if (elem matched onV) then
((matched, v:onMatched), (v, without matched onV):xs)
else
((matched, onMatched), (v, onV): xs)
match :: Node -> Graph -> Maybe (Context, Graph)
match x xs = case idx of
Just (n, c) ->
let
prefix = take n xs
(c', prefix') = foldr transferEdge (c, []) prefix
suffix = drop (n+1) xs
in
Just (c', prefix' ++ suffix)
Nothing -> Nothing
where
idx = findNode x xs
dfs :: [Node] -> Graph -> [Node]
dfs [] _ = []
dfs (v:vs) g = case m of
Just (c, g') -> (fst c):(dfs ((snd c) ++ vs) g')
Nothing -> dfs vs g
where
m = match v g
type MatrixArray = Array Int (Array Int Int)
matrixToGraphHelper' :: Int -> MatrixArray -> (Int, Int) -> Graph -> Graph
matrixToGraphHelper' size ma (row, column) g = ctx:g
where
node = rowColumnToNode size (row, column)
orthoNorthNeighbor :: (Int, Int) -> [Int] -> [Int]
orthoNorthNeighbor (r, c) ns = if row > 0 then
if (ma ! (r - 1) ! c) == 1 then
(rowColumnToNode size (r -1, c)):ns
else ns
else ns
orthoWestNeighbor :: (Int, Int) -> [Int] -> [Int]
orthoWestNeighbor (r, c) ns = if c > 0 then
if (ma ! r ! (c - 1)) == 1 then
rowColumnToNode size (r, (c-1)):ns
else ns
else ns
adj = orthoNorthNeighbor (row, column) (orthoWestNeighbor (row, column) [])
ctx = (node, adj)
matrixToGraphHelper :: Int -> MatrixArray -> (Int, Int) -> Graph -> Graph
matrixToGraphHelper size ma (row, column) g =
if (ma ! row ! column) == 1 then matrixToGraphHelper' size ma (row, column) g else g
matrixToGraph :: Int -> MatrixArray -> Graph
matrixToGraph size ma = foldr f [] idxs
where
idxs = [(size - i - 1, size - j - 1) | i <- [0..(size-1)], j <- [0..(size-1)]]
f = matrixToGraphHelper size ma
type State = ([[Int]], [Int])
type Move = [Int]
moves :: Int -> State -> [Move]
moves k s = if ((length rows) == (length csum)) then [] else kones cs k
where
(rows, csum) = s
cs = map ((>) k) csum
move :: State -> Move -> State
move s m = (m:rows, map (\x -> (fst x) + (snd x)) (zip m cs))
where
(rows, cs) = s
succs :: Int -> State -> [State]
succs k t = [move t m | m <- (moves k t)]
solvedMagic :: Int -> State -> Bool
solvedMagic k s = (length rows) == size && (allTrue (k ==) cs)
where
(rows, cs) = s
size = length cs
solvedConnected :: Int -> State -> Bool
solvedConnected k s = (length rows) == size && (allTrue (k ==) cs) && (length vs == length g)
where
(rows, cs) = s
size = length cs
ma = matrixToArray rows
g = matrixToGraph size ma
sn = fst (head g)
vs = dfs [sn] g
search :: (Int -> State -> Bool) -> Int -> [State] -> [State]
search _ _ [] = []
search solved k (t:ts) = if (solved k t) then t:(search solved k ts) else search solved k (succs k t ++ ts)
solutions :: (Int -> State -> Bool) -> Int -> State -> [State]
solutions solved k t = search solved k [t]
magicSquares :: Int -> Int -> [[[Int]]]
magicSquares size numOnes = map fst (solutions solvedMagic numOnes ([], [0::Int | _ <- [1..size]]))
connectedSquares :: Int -> Int -> [[[Int]]]
connectedSquares size numOnes = map fst (solutions solvedConnected numOnes ([], [0::Int | _ <- [1..size]]))