Google Code Jam 2022 Round 1C Problem A (Haskell)

gcj-2022-r1c-a.hs

-- boilerplate elided from gist

docase :: Int -> IO ()
docase i = do
    printf "Case #%d: " i
    _ <- getLine
    ss <- words <$> getLine
    outimp putStrLn $ solve ss

aside (x:_,_) = x
bside (  _,x) = x
isMono (x:_,y) = x == y

merge (aa,a) (bb,b) = (aa <> bb,b)

canon xx = go S.empty xx where
    go _ [] = error "canon: empty list"
    go _ [x] = Just (xx,x)
    go s (a:b:cc)
        | a /= b && S.member b s = Nothing
        | otherwise = go (S.insert a s) (b:cc)

dups = (/=) . length <*> S.size . S.fromList

solve ss = traverse canon ss >>= solve'

solve' qq
    | dups (map aside mixed) = Nothing
    | dups (map bside mixed) = Nothing
    | otherwise = go [] qmap
  where
    (monos,mixed) = partition isMono qq
    qmap = M.fromListWith (flip merge) $ map f $ monos <> mixed
      where f q@(x:_,_) = (x,q)
    go uu qm
        | not $ S.null start = go uu' qm'
        | otherwise = canon ans <&> \(s,_) -> s
      where
        (ans,_) = foldr1 merge $ M.elems qm <> uu
        start = foldr S.delete (M.keysSet qm) $ map bside $ M.elems qm
        a = S.findMin start
        q = qm M.! a
        b = bside q
        (uu',qm') = case M.lookup b qm of
            Nothing -> (q:uu, M.delete a qm)
            Just r  -> (uu, M.insert a (merge q r) $ M.delete b qm)