Haskell Quiz/Secret Santas/Solution Matthias

this program takes embarassingly long to answer, even for the seven people from the puzzle. but writing it down was easy. rather than computing all results and picking a random one, i think function f should shuffle santas and victims, and then take the first valid solution returned by q. this here works, though, so i'll bail out.

(note that the algorithm itself, without parsing, output, and selection of a random solution, takes only 16 short lines, comments and type signatures included!

module Main where
import Monad
import List
import Random

data P = P String String String deriving (Show, Eq, Ord)

parseP :: String -> P
parseP s = f "" s
    where
    f acc (' ':s) = case g "" s of (lastname, email) -> P (reverse acc) lastname email
    f acc (c:s) = f (c:acc) s

    g acc (' ':s) = (reverse acc, s)
    g acc (c:s) = g (c:acc) s

showPs :: [(P, P)] -> String
showPs = join . map (\ (santa, victim) -> show santa ++ " is secrect santa for " ++ show victim ++ "\n")

main :: IO ()
main = getContents >>= g >>= putStr . showPs

g :: String -> IO [(P, P)]  -- parse input
g i = let k = map parseP $ lines i in f k k

f :: [P] -> [P] -> IO [(P, P)]  -- compute output
f santas victims = do
                   let all = q [] santas victims
                   i <- randomRIO (0, length all - 1)
                   return (all !! i)

-- q takes a partial solution, a pool of remaining santas, and a pool of remaining victims.  it then produces all
-- possible next matches, calls itself recursively, and returns the complete set of all solutions.

q :: [(P, P)] -> [P] -> [P] -> [[(P, P)]]
q acc [] []           = [acc]  -- (found a valid solution)
q acc [] _            = []     -- leftover victims
q acc _ []            = []     -- leftover santas
q acc santas victims  = [ tl | santa <- santas,
                               victim <- victims,
                               matchOk santa victim,
                               tl <- q ((santa, victim) : acc)
                                       (santas \\ [santa])
                                       (victims \\ [victim]) ]

matchOk :: P -> P -> Bool
matchOk (P _ santa _) (P _ victim _) = santa /= victim