19-1: "working" but too slow.

1 files changed, 51 insertions, 0 deletions

diff --git a/19-1.hs b/19-1.hs
new file mode 100644
index 0000000..7bda88c
--- /dev/null
+++ b/19-1.hs
@@ -0,0 +1,51 @@
+import Control.Monad.Trans.State
+import Data.Foldable (foldrM)
+import Data.HashMap.Lazy as HM hiding (filter, mapMaybe, map, null)
+import Data.List (nub)
+import Data.Maybe (mapMaybe)
+
+import Debug.Trace
+
+type S = HashMap 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 :: [String] -> String -> State S [String]
+matchAny yss xs = do
+  s <- get
+  case HM.lookup xs s of
+    Nothing -> let r = mapMaybe (match xs) yss
+               in put (HM.insert xs r s) >> return r
+    Just x -> return x
+
+check :: [String] -> String -> State S Bool
+check yss xs = do
+  zss <- nub <$> matchAny yss xs
+  if [] `elem` zss
+    then return True
+    else anyM (check 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)
+
+main :: IO ()
+main = do
+  input <- getContents
+  let (xss, yss) = parse input
+  print . length . filter id $ evalState (mapM (check xss) yss) HM.empty