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

---

Note that the reason this algorithm takes so long is that it's generating every permutation of the santa/victim list, even though many are the same except for the order. With two people, for example, you'll get:

[ [(A,B),(B,A)], [(B,A),(A,B)] ]

These two are the same list, since the order is not significant. The algorithm can be made efficient by choosing a "canonical" ordering for the pair list, and skipping permutations that are not in that order.

For example, make sure the new pair is "less" than the top pair before adding it to the list of possibilities:

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,
                               null acc || (santa, victim) <= (head acc), -- change
                               tl <- q ((santa, victim) : acc)
                                       (santas \\ [santa])
                                       (victims \\ [victim]) ]

--Kelan 20:41, 30 October 2006 (UTC)

Even simpler is to generate the pairs in the right order from the start:

q :: [P] -> [P] -> [[(P, P)]]
q [] [] = [[]]
q (santa : santas) victims =
   [ (santa, victim) : rest
   | victim <- victims
   , matchOk santa victim
   , rest <- q santas (delete victim victims)
   ]

Note that if the number of santas are the same as the number of victims we don't need the clauses for leftover santas/victims.

Ulfn 13:54, 30 November 2006 (UTC)