Haskell Quiz/Housie/Solution Dolio

< Haskell Quiz | Housie

Categories: Haskell Quiz solutions

This solution uses a two pronged approach to the problem. Naively generating and testing books is too slow. However, if one looks only at whether spaces are empty or filled, the search space is sufficiently small to generate random candidates and search for a valid result among them. This search results in a template for the book, which can then be filled in (with some additional constraint checking) to get the final result.

Since the algorithm involves randomly guessing candidate results, it's possible for it to take a very long time. However, in practice, results usually appear in a matter of seconds.

This code makes use of the random monad.

module Main where
 
import Control.Monad
import Data.List
 
import MonadRandom
 
-- Some handy datatypes and aliases
type Card a = [[a]]
type Book a = [Card a]
 
data Slot = Filled | Vacant deriving (Eq)
 
-- Some general functions
combinations :: [a] -> [a] -> [[a]]
combinations xs [] = [xs]
combinations [] ys = [ys]
combinations (x:xs) (y:ys) = map (x:) (combinations xs (y:ys))
                           ++ map (y:) (combinations (x:xs) ys)
 
splitAtM :: MonadPlus m => Int -> [a] -> m ([a], [a])
splitAtM _ [] = mzero
splitAtM n xs = return $ splitAt n xs
 
select :: MonadRandom m => [a] -> m (a, [a])
select xs = do i <- getRandomR (0, length xs - 1)
               let (f, x:l) = splitAt i xs
               return (x, f ++ l)
 
stream :: MonadRandom m => [a] -> m [a]
stream rs = map (rs !!) `liftM` getRandomRs (0, length rs - 1)
 
slice :: Int -> [a] -> [[a]]
slice n x@(_:tx) = take n x : slice n tx
 
-- Some problem-specific functions
rowTemplates :: [[Slot]]
rowTemplates = combinations (replicate 5 Filled) (replicate 4 Vacant)
 
bounds :: [(Int, Int)]
bounds = zip (1: [10, 20 .. 80]) ([9, 19 .. 79] ++ [90])
 
validateCol :: [Int] -> Bool
validateCol c = nc == (nub . sort $ nc)
 where nc = filter (> 0) c
 
-- For creating an entire book
bookTemplates :: MonadRandom m => [[Slot]] -> m [[[Slot]]]
bookTemplates rs = (filter validateBookTemplate . slice 18) `liftM` stream rs
 
validateBookTemplate :: [[Slot]] -> Bool
validateBookTemplate b = and $ zipWith (==) fls bls
 where
 fls = map (length . filter (== Filled)) . transpose $ b
 bls = map (length . uncurry enumFromTo) bounds
 
fillBook :: MonadRandom m => [[Slot]] -> m (Book Int)
fillBook bt = liftM (unfoldr (splitAtM 3) . transpose)
                . mapM fill . zip bounds . transpose $ bt
 where
 fill (b,c) = do c' <- f (uncurry enumFromTo b) c
                 if all validateCol (unfoldr (splitAtM 3) c')
                    then return c'
                    else fill (b, c)
 f _ []          = return []
 f b (Vacant:xs) = liftM (0:) (f b xs)
 f b (Filled:xs) = do (r, b') <- select b
                      liftM (r:) (f b' xs)
 
-- For output
intercalate s = concat . intersperse s
 
showCard = unlines . map (intercalate "|") . map (map showN)
 where
 showN n
    | n == 0    = "  "
    | n < 10    = " " ++ show n
    | otherwise = show n
 
showBook = intercalate "\n" . map showCard
 
main = bookTemplates rowTemplates >>= fillBook . head
            >>= putStrLn . showBook

Recent content is available under a simple permissive license.