santa.hs

import Control.Arrow
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.List
import Data.Random.Extras
import Data.Random.RVar
import Data.Random.Source.DevRandom
type Pairing = (String, String)
type Possibility = (String, [String])

people :: [String]
people = [ "Nick", "Adam", "Affan", "George", "Lily", "Pants", "Toby", "Duncan",
           "Sienna"]

draw :: [String] -> [Possibility]
draw xs = [ (x, delete x xs) | x <- xs ]

filt :: (String -> String -> Bool) -> Possibility -> Possibility
filt f (x, ys) = (x, filter (f x) ys)

f :: String -> String -> Bool
f "Lily" x = case x of
  "Pants" -> False
  _ -> True
f "Pants" x = case x of
  "Lily" -> False
  _ -> True
f _ _ = True

santas :: [Possibility]
santas = map (filt f) $ draw people

santa :: [Possibility] -> MaybeT IO [Pairing]
santa [] = return []
santa ((x, ys):ss) = do
  rvar <- MaybeT . return $ safeChoice ys
  pick <- lift $ runRVar rvar DevRandom
  rest <- santa $ map (second $ filter (/= pick)) ss
  -- rest <- santa $ map (\(x', ys') -> (x', filter (/= pick) ys')) ss
  return $ (x, pick) : rest

dontFail :: MaybeT IO [Pairing] -> IO [Pairing]
dontFail x = fix (\again -> runMaybeT x >>= maybe again pure)
-- dontFail x = runMaybeT x >>= maybe (dontFail x) return

main :: IO ()
main = dontFail (santa santas) >>= mapM_ write

write :: Pairing -> IO ()
write = uncurry writeFile