Haskell Quiz/Housie/Solution Dolio

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