GCHQ 2015 Puzzle in Haskell

GCHQ.hs

module Main(main) where

import Data.Maybe
import Data.List

-- Data table copied from https://matthewearl.github.io/2015/12/10/gchq-xmas-card/
width = 25
height = 25
rows = [
    [7, 3, 1, 1, 7],
    [1, 1, 2, 2, 1, 1],
    [1, 3, 1, 3, 1, 1, 3, 1],
    [1, 3, 1, 1, 6, 1, 3, 1],
    [1, 3, 1, 5, 2, 1, 3, 1],
    [1, 1, 2, 1, 1],
    [7, 1, 1, 1, 1, 1, 7],
    [3, 3],
    [1, 2, 3, 1, 1, 3, 1, 1, 2],
    [1, 1, 3, 2, 1, 1],
    [4, 1, 4, 2, 1, 2],
    [1, 1, 1, 1, 1, 4, 1, 3],
    [2, 1, 1, 1, 2, 5],
    [3, 2, 2, 6, 3, 1],
    [1, 9, 1, 1, 2, 1],
    [2, 1, 2, 2, 3, 1],
    [3, 1, 1, 1, 1, 5, 1],
    [1, 2, 2, 5],
    [7, 1, 2, 1, 1, 1, 3],
    [1, 1, 2, 1, 2, 2, 1],
    [1, 3, 1, 4, 5, 1],
    [1, 3, 1, 3, 10, 2],
    [1, 3, 1, 1, 6, 6],
    [1, 1, 2, 1, 1, 2],
    [7, 2, 1, 2, 5]
    ]

cols = [
    [7, 2, 1, 1, 7],
    [1, 1, 2, 2, 1, 1],
    [1, 3, 1, 3, 1, 3, 1, 3, 1],
    [1, 3, 1, 1, 5, 1, 3, 1],
    [1, 3, 1, 1, 4, 1, 3, 1],
    [1, 1, 1, 2, 1, 1],
    [7, 1, 1, 1, 1, 1, 7],
    [1, 1, 3],
    [2, 1, 2, 1, 8, 2, 1],
    [2, 2, 1, 2, 1, 1, 1, 2],
    [1, 7, 3, 2, 1],
    [1, 2, 3, 1, 1, 1, 1, 1],
    [4, 1, 1, 2, 6],
    [3, 3, 1, 1, 1, 3, 1],
    [1, 2, 5, 2, 2],
    [2, 2, 1, 1, 1, 1, 1, 2, 1],
    [1, 3, 3, 2, 1, 8, 1],
    [6, 2, 1],
    [7, 1, 4, 1, 1, 3],
    [1, 1, 1, 1, 4],
    [1, 3, 1, 3, 7, 1],
    [1, 3, 1, 1, 1, 2, 1, 1, 4],
    [1, 3, 1, 4, 3, 3],
    [1, 1, 2, 2, 2, 6, 1],
    [7, 1, 3, 2, 1, 1]
    ]

givens = [
  (3, 3), (3, 4), (3, 12), (3, 13), (3, 21),
  (8, 6), (8, 7), (8, 10), (8, 14), (8, 15), (8, 18),
  (16, 6), (16, 11), (16, 16), (16, 20),
  (21, 3), (21, 4), (21, 9), (21, 10), (21, 15), (21, 20), (21, 21)
    ]

grid0 = [[if (r-1,c-1) `elem` givens then Just True else Nothing | c <- [1..25]] | r <- [1..25]]

main :: IO ()
main = putStr $ unlines $ showGrid $ fromJust $
    constrainGrid rows cols =<< constrainGrid rows cols =<< constrainGrid rows cols =<< constrainGrid rows cols grid0

-- | Given a set of tilings, say how many cells are required
requires :: [Int] -> Int
requires [] = 0
requires xs = sum xs + length xs - 1

showGrid :: [[Maybe Bool]] -> [String]
showGrid = map $ map shw
    where shw x = case x of Nothing -> '.'; Just x -> if x then 'X' else 'O'

constrainGrid :: [[Int]] -> [[Int]] -> [[Maybe Bool]] -> Maybe [[Maybe Bool]]
constrainGrid rows cols xs = fmap transpose . constrainSide cols . transpose =<< constrainSide rows xs

constrainSide :: [[Int]] -> [[Maybe Bool]] -> Maybe [[Maybe Bool]]
constrainSide cs xs = sequence $ zipWith constrainLine cs xs

constrainLine :: [Int] -> [Maybe Bool] -> Maybe [Maybe Bool]
constrainLine cs xs = if null xs2 then Nothing else mapM f $ transpose xs2
    where xs2 = tile cs xs
          f (x:xs) = Just $ if not x `elem` xs then Nothing else Just x


tile :: [Int] -> [Maybe Bool] -> [[Bool]]
tile [] xs = maybeToList $ xs ~> replicate (length xs) False
tile (c:cs) xs = concat [map (\r -> a ++ b ++ c ++ r) $ tile cs xs
    | gap <- [0 .. length xs - (c + sum cs + length cs)]
    , (false,xs) <- [splitAt gap xs], (true,xs) <- [splitAt c xs], (space,xs) <- [splitAt 1 xs]
    , Just a <- [false ~> replicate gap False], Just b <- [true ~> replicate c True]
    , Just c <- [space ~> replicate (length space) False]]

(~>) :: [Maybe Bool] -> [Bool] -> Maybe [Bool]
(~>) xs ys = if length xs == length ys && and (zipWith (\x y -> maybe True (== y) x) xs ys) then Just ys else Nothing