# Haskell Quiz/Secret Santas/Solution Matthias

### From HaskellWiki

< Haskell Quiz | Secret Santas(Difference between revisions)

m |
|||

Line 3: | Line 3: | ||

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. |
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! |
+ | note that the algorithm itself, without parsing, output, and selection of a random solution, takes only 16 short lines, comments and type signatures included! |

<haskell> |
<haskell> |

## Revision as of 11:59, 26 October 2006

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