Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
GCHQ 2015 Puzzle in Haskell
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment