Faster 24

aelg-haskell/src/Twentyfour.hs

@@ -4,6 +4,8 @@ module Twentyfour
 
 import           Data.List
 import           Data.Tuple
+import           Data.Maybe
+import qualified Data.Map.Strict as M
 import           Text.ParserCombinators.ReadP
 
 parse :: [String] -> [(Int, Int)]
@@ -15,32 +17,73 @@ parse = map (fst . last . readP_to_S p)
       b <- many1 get
       return (read a, read b)
 
-bridges l = go m 0
+newtype Tree = Node ((Int, Int), [Tree]) deriving Show
+
+type ComponentSet = M.Map Int [Int]
+
+cSetAdd cSet (a,b) = M.alter (f a) b (M.alter (f b) a cSet)
+  where
+    f a = maybe (Just [a]) (\xs -> Just (a : xs))
+
+cSetFromList :: [(Int, Int)] -> ComponentSet
+cSetFromList = go M.empty
+  where
+    go cSet [] = M.empty
+    go cSet (x:xs) = cSetAdd (go cSet xs) x
+
+cSetDelete cSet (a,b) = M.alter (f a) b (M.alter (f b) a cSet)
+  where
+    f a b = Just (delete a $ fromJust b)
+
+cSetLookup cSet a = fromMaybe [] (M.lookup a cSet)
+
+bridges :: ComponentSet -> [Tree]
+bridges m = go m 0
   where
-    m = l ++ map swap l
+    go :: ComponentSet -> Int -> [Tree]
     go m a
-      | null allFitting = [[]]
-      | otherwise = concatMap f allFitting
+      | null allFitting = []
+      | otherwise = map f allFitting
       where
-        allFitting = filter ((== a) . fst) m
-        f (a,c) = map ((a,c):) $ go nM c
+        allFitting = cSetLookup m a
+        f :: Int -> Tree
+        f c = Node ((a,c), go nM c)
           where
-            nM = delete (a,c) $ delete (c,a) m
+            nM = cSetDelete m (a,c)
 
 sumP (a,b) = a+b
 
 strength a = sum (map sumP a)
 
 strongest a b = strength a `compare` strength b
 
-solve1 = maximum . map strength
+maxDepth :: [Tree] -> (Int, Int) -- (strength, depth)
+maxDepth [] = (0, 0)
+maxDepth trees = maximum $ map go trees
+  where
+    go (Node ((a,b), trees)) = (a+b+s, d + 1)
+      where (s, d) = maxDepth trees
 
-solve2 = strength . maximumBy comp
+maxStrength :: [Tree] -> (Int, Int) -- (strength, depth)
+maxStrength [] = (0, 0)
+maxStrength trees = maximumBy comp $ map go trees
   where
-    comp a b
-      | length a /= length b = length a `compare` length b
-      | otherwise = strongest a b
+    (s1,d1) `comp` (s2,d2)
+      | d1 /= d2 = d1 `compare` d2
+      | otherwise = s1 `compare` s2
+    go (Node ((a,b), trees)) = (a+b+s, d + 1)
+      where (s, d) = maxStrength trees
+
+nodes :: [Tree] -> Int
+nodes [] = 1
+nodes trees = sum $ map go trees
+  where
+    go (Node ((a,b), trees)) = nodes trees
+
+solve1 = fst . maxDepth
+
+solve2 = fst . maxStrength
 
 solve :: [String] -> (String, String)
 solve s = (show $ solve1 l, show $ solve2 l)
-  where l = bridges . parse $ s
+  where l = bridges . cSetFromList . parse $ s