diff options
Diffstat (limited to 'Puzzle7.hs')
| -rw-r--r-- | Puzzle7.hs | 106 |
1 files changed, 53 insertions, 53 deletions
@@ -2,6 +2,7 @@ import Data.Set (toList, (\\), fromList) import Data.List.Split (splitOn, splitOneOf) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (fromJust) parseInput :: [Char] -> [[Char]] parseInput xs = filter (elem '>') (splitOn "\n" xs) @@ -11,7 +12,6 @@ parseInput xs = filter (elem '>') (splitOn "\n" xs) f :: [[Char]] -> [[[Char]]] f xs = filter (not . null) <$> splitOneOf (['0' .. '9'] ++ ",()-> ") <$> xs --- g :: [[[Char]]] -> ([[Char]], [[Char]]) g xs = (head <$> xs, mconcat (tail <$> xs)) @@ -21,58 +21,58 @@ solve1FromPair (xs, ys) = head $ toList $ (fromList xs) \\ (fromList ys) solve1 :: [Char] -> [Char] solve1 = solve1FromPair . g . f . parseInput -parseLine xs = (node, (weight, children)) - where node:weight:children = splitOneOf ",()-> " xs - -parseInput' xs = Map.fromList . (fmap parseLine) . (splitOn "\n") xs - -update nodes weights node - | null children = Map.insert node weight weights - | otherwise = fromJust . Map.lookup $ foldl (newWeights nodes) weights children - where (weight, children) = fromJust . Map.lookup node nodes - -newWeights nodes weights node = - if member node weights - then weights - else update nodes weights node - -findAnomaly xs - | null ys = Nothing - | length ys > 1 = Just $ fst $ head xs - | otherwise = Just $ fst $ head ys - where ys = filter (\z -> snd z /= snd head xs) xs - - -solve2' nodes node weight - fst $ until (isNothing . snd) badChild (root, Just root) - where - root = solve1 input - badChild x - | isNothing $ snd x = x - | otherwise = findAnomaly (\z -> (z, fromJust $ Map.lookup z weights)) <$> (snd . fromJust . Map.lookup y) nodes - where y = fromJust . snd x - - - - - - - - - - - - - - - - - - - - - - +parseLine :: [Char] -> ([Char], (Int, [[Char]])) +parseLine xs = (node, (read weight, children)) + where node:weight:children = filter (not . null) $ splitOneOf ",()-> " xs + +parseInput' :: [Char] -> Map [Char] (Int, [[Char]]) +parseInput' = Map.fromList . (fmap parseLine) . (splitOn "\n") + +getWeights :: Map [Char] (Int, [[Char]]) -> [Char] -> Map [Char] Int +getWeights tree node = + if null children + then Map.singleton node weight + else Map.insert node (weight + (sum $ lookups children childrenWeights)) childrenWeights + where (weight, children) = fromJust $ Map.lookup node tree + childrenWeights = Map.unions $ getWeights tree <$> children + +findAnomaly :: Map [Char] (Int, [[Char]]) -> Map [Char] Int -> [Char] -> [Char] +findAnomaly tree weights node + | null children = node + | maximum cWeights == minimum cWeights = node + | otherwise = findAnomaly tree weights $ badChild childrenWithWeights + where children = snd $ fromJust $ Map.lookup node tree + cWeights = lookups children weights + childrenWithWeights = zipWith (,) children cWeights + +lookups :: [[Char]] -> Map [Char] a -> [a] +lookups xs ys = (\x -> fromJust $ Map.lookup x ys) <$> xs + +badChild :: [([Char], Int)] -> [Char] +badChild (x:y:z:xs) = + if (snd x) /= (snd y) + then if (snd y) == (snd z) + then fst x + else fst y + else fst $ head $ filter ((/= snd x) . snd) (z:xs) + +weightDiff :: [Int] -> Int +weightDiff (x:y:z:xs) = + if x /= y + then if y == z + then z - x + else z - y + else head (filter (/= x) (z:xs)) - x + +solve2 :: [Char] -> Int +solve2 xs = + wd + (fst $ fromJust $ Map.lookup node tree) + where tree = parseInput' xs + root = solve1 xs + rootChildren = snd $ fromJust $ Map.lookup root tree + weights = getWeights tree root + wd = weightDiff $ lookups rootChildren weights + node = findAnomaly tree weights root input0 = "pbga (66)\nxhth (57)\nebii (61)\nhavc (66)\nktlj (57)\nfwft (72) -> ktlj, cntj, xhth\nqoyq (66)\npadx (45) -> pbga, havc, qoyq\ntknk (41) -> ugml, padx, fwft\njptl (61)\nugml (68) -> gyxo, ebii, jptl\ngyxo (61)\ncntj (57)" |