Skip to content

Instantly share code, notes, and snippets.

Embed
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
You can’t perform that action at this time.