https://codeiq.jp/ace/yuki_hiroshi/q321

shufflers.hs

import Control.Applicative ((<$>))
import Data.List (sort, intersect, foldl', nub)
import qualified Data.Map as M

type Id      = Int
type IdList  = [Id]
type Name    = String
type Tmpids  = M.Map Name [[Id]]
type Workids = M.Map [Id] [Name]

data User = Def Id Name       -- IDが決定したユーザー
          | Undef [Id] [Name] -- IDが決定できなかったユーザー

instance Show User where
    show (Def   iden  name)  = show iden ++ " = " ++ name
    show (Undef idens names) = unwords (map show idens) ++ " = " ++ unwords names

instance Eq User where
    (Def   ia  na)  == (Def   ib  nb)  = ia  == ib  && na  == nb
    (Undef ias nas) == (Undef ibs nbs) = ias == ibs && nas == nbs
    _               == _               = False

instance Ord User where
    compare (Def   ia  na)  (Def   ib  nb)  = compare (ia, na)     (ib, nb)
    compare (Undef ias nas) (Undef ibs nbs) = compare (ias, nas)   (ibs, nbs)
    compare (Def   ia  na)  (Undef ibs nbs) = compare ([ia], [na]) (ibs, nbs)
    compare (Undef ias nas) (Def   ib  nb)  = compare (ias, nas)   ([ib], [nb])

main :: IO ()
main = do
    ls <- lines . removeCR <$> getContents
    let shuf = parseShufflers ls
        res  = sort $ shufflers shuf []
    mapM_ (putStrLn . show) res

-- 入力データを全部読み込んで、処理しやすいデータ構造に落とし込む
parseShufflers :: [String] -> Tmpids
parseShufflers ls = M.map nub tmpids
  where
    tmpids = foldr (uncurry buildTempids) M.empty . map parseIdAndNames $ ls

    buildTempids :: [Id] -> [Name] -> Tmpids -> Tmpids
    buildTempids ids names tids = foldl' build tids names
      where
        build :: Tmpids -> Name -> Tmpids
        build tmp name0 = M.insertWith (++) name0 [ids] tmp

    parseIdAndNames :: String -> ([Id], [Name])
    parseIdAndNames line = (map read ids, names)
      where
        (ids, (_:names)) = break (== "=") $ words line -- 捨てているのは "=" の部分

-- ロジックの心臓部
shufflers :: Tmpids -> [User] -> [User]
shufflers tmpids acc
    | null us   = exitShufflers tmpids acc
    | otherwise = shufflers tmpids' (us' ++ acc)
  where
    us = uniqs tmpids -- us は id が決定した name と id のリスト
    us' = map (\(name, iden) -> Def iden name) us --  User 型に変換
    (names, ids) = unzip us
    tmpids' = updateIds ids $ updateNames names tmpids -- 決定した name と id を削除する

-- 積集合の要素(ID)が 1 つになる名前とIDを求める
uniqs :: Tmpids -> [(Name, Id)]
uniqs = map (\(n, ids) -> (n, head ids)) . filter (onlyone . snd) . M.toList . M.map intersects

-- Map 中のデータから ids にある ID を削除する
updateIds :: [Id] -> Tmpids -> Tmpids
updateIds ids = M.map update'
  where
    update' :: [[Id]] -> [[Id]]
    update' = filter (not . null) . map (filter (`notElem` ids))

-- Map中のデータから names にある key のデータを削除する
updateNames :: [Name] -> Tmpids -> Tmpids
updateNames names tmpids = foldr M.delete tmpids names

-- 未決定の id と name の処理
exitShufflers :: Tmpids -> [User] -> [User]
exitShufflers tmpids acc = map (uncurry Undef) (M.toList users) ++ acc
  where
    pairs :: [([IdList], Name)]
    pairs = map swap $ M.toList tmpids

    users :: Workids
    users = M.map nub $ merge pairs M.empty

    merge :: [([IdList], Name)] -> Workids -> Workids
    merge (p0:ps) tids = merge ps $ appendIds p0 tids
    merge []      tids = tids

    appendIds :: ([IdList], Name) -> Workids -> Workids
    appendIds (idsl, name) tids = foldl' (appendName name) tids idsl

    appendName :: Name -> Workids -> IdList -> Workids
    appendName name tids ids = M.insertWith (++) ids [name] tids

intersects :: Eq a => [[a]] -> [a]
intersects = foldr1 intersect

onlyone :: [a] -> Bool
onlyone [_] = True
onlyone _   = False

swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)

removeCR :: String -> String
removeCR = filter (/= '\r')