import Control.Monad.ST import Data.Foldable (foldrM) import Data.HashTable.ST.Basic as H import Data.List (nub) import Data.Maybe (mapMaybe) import Debug.Trace type S s = H.HashTable s String [String] -- Return Nothing if no match; unmatched remainder (can be []) if -- match. match :: String -> String -> Maybe String match xs [] = Just xs match (x:xs) (y:ys) | x == y = match xs ys | otherwise = Nothing match [] _ = Nothing matchAny :: S s -> [String] -> String -> ST s [String] matchAny s yss xs = do t <- H.lookup s xs case t of Nothing -> let r = mapMaybe (match xs) yss in H.insert s xs r >> return r Just x -> return x check :: S s -> [String] -> String -> ST s Bool check s yss xs = do zss <- nub <$> matchAny s yss xs if [] `elem` zss then return True else anyM (check s yss) zss anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM p = foldrM f False where f a b = (b ||) <$> p a parseTowels :: String -> [String] parseTowels = map init . words parse :: String -> ([String],[String]) parse s = let yss = filter (not . null) . drop 2 $ lines s xss = parseTowels . head $ lines s in (xss, yss) run :: [String] -> [String] -> ST s Int run xss yss = do ht <- H.new :: ST s (S s) length . filter id <$> traverse (check ht yss) xss main :: IO () main = do input <- getContents let (xss, yss) = parse input print $ runST $ run yss xss