Haskell Quiz/Secret Santas/Solution Kuklewicz

This solution builds the result one cycle of gift givers at a time. When there are no valid additional moves it backtracks to make a different random choice. It uses the MonadRandom available on this wiki and code from oleg for the shuffling.

{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields #-}
-- Backtracking solution by Chris Kuklewicz <haskell@list.mightyreason.com>
-- http://haskell.org/haskellwiki/Haskell_Quiz/Secret_Santas
-- http://www.rubyquiz.com/quiz2.html

-- The chain of santas is cyclic.  This picks an initial person from
-- the remaining pool and creates a chain of secret santas until the
-- cycle is finished.  Then it is either done or it creates the next
-- cycle.  If a cycle cannot be completed then it backtracks and makes
-- a different choice of possible branches.

-- I believe this is a "fair" way of randomizing the assignments.
module Main where
import Control.Monad.Fix (fix)
import Data.Monoid
import Data.List (delete)
import System.Random (StdGen,newStdGen)
import MonadRandom(MonadRandom,Rand,getRandomR,evalRand) -- from http://haskell.org/haskellwiki/New_monads/MonadRandom

data Person = P {firstName,lastName,email :: !String}
  deriving (Show,Eq,Ord)

main = do
  input <- readFile "/tmp/input1"
  let people = map parsePerson (lines input)
  g <- newStdGen
  case assign people g of
    Nothing -> print "Failed"
    Just santas -> putStr (unlines (map showSanta santas))

parsePerson :: String -> Person
parsePerson line = P {firstName=a,lastName=b, email=c}
  where [a,b,c] = words line

showSanta (p1,p2) = (showPerson p1) ++ " -> " ++ (showPerson p2)
  where showPerson (P {firstName=a,lastName=b, email=c}) = unwords [a,b,c]

assign :: [Person] -> StdGen -> Maybe [(Person,Person)]
assign ps g = evalRand (assignAll ps) g

assignAll :: [Person] -> Rand StdGen (Maybe [(Person,Person)])
assignAll [] = return $ Just []
assignAll [_] = return Nothing
assignAll (initial:rest) = startCycle initial rest

startCycle :: Person -> [Person] -> Rand StdGen (Maybe [(Person,Person)])
startCycle _ [] = error "Cannot happen"
startCycle initial rest = do
  others <- shuffle (validOthers initial rest)
  let branches = map doBranch others
      doBranch latest = prepend initial latest $ continueCycle initial latest (delete latest rest)
  firstJust branches

continueCycle :: Person -> Person -> [Person] -> Rand StdGen (Maybe [(Person,Person)])
continueCycle initial previous rest | initial == previous = assignAll rest -- cycle was closed
                                    | otherwise = do
  others <- shuffle (validOthers previous (initial:rest))
  let branches = map doBranch others
      doBranch latest = prepend previous latest $ continueCycle initial latest (delete latest rest)
  firstJust branches
          
-- validOthers is used to exclude family members from the possibilities
validOthers (P {lastName=santaFamily}) = filter ((santaFamily/=).lastName)

-- helper function to build answer
prepend a b mv = do
  v <- mv 
  return $ case v of Nothing -> Nothing
                     Just cs ->  Just $ (a,b):cs

-- firstJust handles the backtracking on failure
firstJust [] = return Nothing
firstJust (mv:mvs) = do
  v <- mv
  case v of Nothing -> firstJust mvs
            Just _ -> return v

-- fairly randomize the order of a list
shuffle :: (MonadRandom m) => [a] -> m [a]
shuffle [] = return []
shuffle x@[_] = return x
shuffle xs = do
  let n = length xs
  rseq <- mapM (\i -> getRandomR (0,n-i)) [1..(n-1)]
  return (shuffle1 xs rseq)

-- Fair Shuffle copied from http://okmij.org/ftp/Haskell/perfect-shuffle.txt

-- A complete binary tree, of leaves and internal nodes.
-- Internal node: Node card l r
-- where card is the number of leaves under the node.
-- Invariant: card >=2. All internal tree nodes are always full.
data Tree a = Leaf !a | Node !Int !(Tree a) !(Tree a) deriving Show

build_tree = (fix grow_level) . (map Leaf)
	where
	     grow_level self [node] = node
	     grow_level self l = self $ inner l
	     
	     inner [] = []
	     inner [e] = [e]
	     inner (e1:e2:rest) = (join e1 e2) : inner rest
	     
	     join l@(Leaf _)       r@(Leaf _)       = Node 2 l r
	     join l@(Node ct _ _)  r@(Leaf _)       = Node (ct+1) l r
	     join l@(Leaf _)       r@(Node ct _ _)  = Node (ct+1) l r
	     join l@(Node ctl _ _) r@(Node ctr _ _) = Node (ctl+ctr) l r

-- given a sequence (e1,...en) to shuffle, and a sequence
-- (r1,...r[n-1]) of numbers such that r[i] is an independent sample
-- from a uniform random distribution [0..n-i], compute the
-- corresponding permutation of the input sequence.

shuffle1 elements rseq = shuffle1' (build_tree elements) rseq
	where
	     shuffle1' (Leaf e) [] = [e]
	     shuffle1' tree (r:r_others) = 
		let (b,rest) = extract_tree r tree
		in b:(shuffle1' rest r_others)

	     extract_tree 0 (Node _ (Leaf e) r) = (e,r)
	     extract_tree 1 (Node 2 (Leaf l) (Leaf r)) = (r,Leaf l)
	     extract_tree n (Node c (Leaf l) r) =
		let (e,new_r) = extract_tree (n-1) r
		in (e,Node (c-1) (Leaf l) new_r)
	     extract_tree n (Node n1 l (Leaf e)) 
			| n+1 == n1 = (e,l)
				       
	     extract_tree n (Node c l@(Node cl _ _) r) 
			| n < cl = let (e,new_l) = extract_tree n l
				   in (e,Node (c-1) new_l r)
			| otherwise = let (e,new_r) = extract_tree (n-cl) r
				      in (e,Node (c-1) l new_r)

link title