commit 4d98e4fd6622911bbff3a5e1721d2510a9327984
parent ea977c0076b5f527745b27f2d14dee4ec3d8e3b8
Author: Ethan Long <ethandavidlong@gmail.com>
Date: Thu, 5 Dec 2024 19:32:53 +1100
Finished Day 5
Part 2 was rough for me. I struggled with creating a sorting function
that took into account the transitive nature of the ordering rules.
Diffstat:
4 files changed, 214 insertions(+), 6 deletions(-)
diff --git a/aoc2024.cabal b/aoc2024.cabal
@@ -69,6 +69,7 @@ library
Day2
Day3
Day4
+ Day5
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
diff --git a/src/Day5.hs b/src/Day5.hs
@@ -0,0 +1,204 @@
+module Day5 (solution) where
+
+import Utils (SolType(..), safeRead)
+
+import Control.Monad (liftM, join)
+import GHC.Num (integerToInt)
+import Data.Maybe (catMaybes)
+import Data.List (sortBy, nub)
+import Debug.Trace (trace)
+
+input :: IO String
+input = readFile "inputs/day5"
+
+exampleInput = join
+ [ "47|53\n"
+ , "97|13\n"
+ , "97|61\n"
+ , "97|47\n"
+ , "75|29\n"
+ , "61|13\n"
+ , "75|53\n"
+ , "29|13\n"
+ , "97|29\n"
+ , "53|29\n"
+ , "61|53\n"
+ , "97|53\n"
+ , "61|29\n"
+ , "47|13\n"
+ , "75|47\n"
+ , "97|75\n"
+ , "47|61\n"
+ , "75|61\n"
+ , "47|29\n"
+ , "75|13\n"
+ , "53|13\n"
+ , "\n"
+ , "75,47,61,53,29\n"
+ , "97,61,53,29,13\n"
+ , "75,29,13\n"
+ , "75,97,47,61,53\n"
+ , "61,13,29\n"
+ , "97,13,75,29,47\n"
+ ]
+
+type Rule = (Integer, Integer)
+type Update = [Integer]
+
+contains :: Eq a => a -> [a] -> Bool
+contains a (b:bs)
+ | a == b = True
+ | otherwise = contains a bs
+contains _ [] = False
+
+replace :: Eq a => a -> a -> [a] -> [a]
+replace = helper []
+ where
+ helper :: Eq a => [a] -> a -> a -> [a] -> [a]
+ helper acc og repl (x:xs)
+ | x == og = helper (repl:acc) og repl xs
+ | otherwise = helper (x:acc) og repl xs
+ helper acc _ _ [] = reverse acc
+
+safeTuple :: Maybe [a] -> Maybe (a, a)
+safeTuple (Just (a:b:_)) = Just (a,b)
+safeTuple _ = Nothing
+
+-- | Parse the puzzle input string into a list of either rules or updates
+-- Example:
+-- >>> parse "42|13"
+-- [Left (42,13)]
+-- >>> parse "61,13,29"
+-- [Right [61,13,29]]
+-- >>> parse "61,13,29\n51,13,29"
+-- [Right [61,13,29],Right [51,13,29]]
+-- >>> parse "42|13\n\n61,13,29"
+-- [Left (42,13),Right [61,13,29]]
+-- >>> parse exampleInput
+-- [Left (47,53),Left (97,13),Left (97,61),Left (97,47),Left (75,29),Left (61,13),Left (75,53),Left (29,13),Left (97,29),Left (53,29),Left (61,53),Left (97,53),Left (61,29),Left (47,13),Left (75,47),Left (97,75),Left (47,61),Left (75,61),Left (47,29),Left (75,13),Left (53,13),Right [75,47,61,53,29],Right [97,61,53,29,13],Right [75,29,13],Right [75,97,47,61,53],Right [61,13,29],Right [97,13,75,29,47]]
+parse :: String -> [Either Rule Update]
+parse s = catMaybes $ map helper $ lines s
+ where
+ helper :: String -> Maybe (Either Rule Update)
+ helper l = case (contains '|' l, contains ',' l) of
+ (True, False) -> liftM Left $ safeTuple $ sequence $ map (safeRead @Integer) $ words $ replace '|' ' ' l
+ (False, True) -> liftM Right $ sequence $ map (safeRead @Integer) $ words $ replace ',' ' ' l
+ _ -> Nothing
+
+-- | Split the parsed puzzle for easier use
+-- Example:
+-- >>> (\(x,y) -> (reverse x, reverse y)) $ splitParsed $ parse exampleInput
+-- ([(47,53),(97,13),(97,61),(97,47),(75,29),(61,13),(75,53),(29,13),(97,29),(53,29),(61,53),(97,53),(61,29),(47,13),(75,47),(97,75),(47,61),(75,61),(47,29),(75,13),(53,13)],[[75,47,61,53,29],[97,61,53,29,13],[75,29,13],[75,97,47,61,53],[61,13,29],[97,13,75,29,47]])
+splitParsed :: [Either Rule Update] -> ([Rule], [Update])
+splitParsed = helper [] []
+ where
+ helper :: [Rule] -> [Update] -> [Either Rule Update] -> ([Rule], [Update])
+ helper accL accR (x : xs) = case x of
+ Left p -> helper (p:accL) accR xs
+ Right l -> helper accL (l:accR) xs
+ helper accL accR [] = (accL, accR)
+
+-- | Check if an update takes the rules into account as according to part 1
+-- Example:
+-- >>> let (rules, updates) = splitParsed $ parse exampleInput in reverse $ map (updateFollowsOrdering rules) updates
+-- [True,True,True,False,False,False]
+updateFollowsOrdering :: [Rule] -> Update -> Bool
+updateFollowsOrdering = helper []
+ where
+ helper :: Update -> [Rule] -> Update -> Bool
+ helper prev rules (x:xs) = obeysRules prev rules x
+ && helper (x:prev) rules xs
+ helper _ _ [] = True
+ obeysRules :: Update -> [Rule] -> Integer -> Bool
+ obeysRules prev rules x = all (obeysRule prev x) rules
+ obeysRule :: Update -> Integer -> Rule -> Bool
+ obeysRule (prev:prevs) x (a, b)
+ | x == b = True
+ | prev == b && x == a = False
+ | otherwise = obeysRule prevs x (a, b)
+ obeysRule [] _ _ = True
+
+-- | Get the middle element of a list
+-- Example:
+-- >>> middleNumber [75,47,61,53,29]
+-- 61
+-- >>> middleNumber [97,61,53,29,13]
+-- 53
+-- >>> middleNumber [75,29,13]
+-- 29
+-- >>> middleNumber [75,97,47,61,53]
+-- 47
+-- >>> middleNumber [61,13,29]
+-- 13
+-- >>> middleNumber [97,13,75,29,47]
+-- 75
+middleNumber :: [a] -> a
+middleNumber = helper [] 0
+ where
+ helper :: [a] -> Integer -> [a] -> a
+ helper acc t (x:xs) = helper (x:acc) (t+1) xs
+ helper acc t _ = acc !! (integerToInt t `div` 2)
+
+-- | Solution to day 5 part 1
+-- Example
+-- >>> solution1 exampleInput
+-- 143
+solution1 :: String -> Integer
+solution1 s = sum middles
+ where
+ (rules, updates) = splitParsed $ parse s
+ filtUps = filter (updateFollowsOrdering rules) updates
+ middles = map middleNumber filtUps
+
+{-
+-- Someone else's solution, they use an intmap, where the key is the LHS, and
+-- the value is the RHS.
+-- I was having a lot of trouble getting this part right, so I ended up giving
+-- up.
+-- Thanks to Quasido!
+-- https://gitlab.com/Quasido/advent-of-code-2024/-/blob/master/05/Main.hs
+ordPages :: RuleMap -> Int -> Int -> Ordering
+ordPages rm left right = case elem right subs of
+ True -> GT
+ _ -> EQ
+ where subs = M.findWithDefault [] left rm
+-}
+
+ruleSort :: [Rule] -> Integer -> Integer -> Ordering
+ruleSort ((a,b):rs) x y
+ | a == x && b == y = GT
+ | a == x && y `elem` subs = GT
+ | otherwise = ruleSort rs x y
+ where subs = map snd $ filter (\(l,_) -> l == x) rs
+ruleSort [] _ _ = EQ
+
+-- | Given an incorrect update, find a correct update of the same integers
+-- Example:
+-- >>> let (rules, _) = splitParsed $ parse exampleInput in findCorrectOrder rules [75,97,47,61,53]
+-- [97,75,47,61,53]
+-- >>> let (rules, _) = splitParsed $ parse exampleInput in findCorrectOrder rules [61,13,29]
+-- [61,29,13]
+-- >>> let (rules, _) = splitParsed $ parse exampleInput in findCorrectOrder rules [97,13,75,29,47]
+-- [97,75,47,29,13]
+-- >>> let (rules, parsed) = splitParsed $ parse exampleInput in all (updateFollowsOrdering rules) $ map (findCorrectOrder rules) parsed
+-- True
+findCorrectOrder :: [Rule] -> Update -> Update
+findCorrectOrder rules = reverse . sortBy (ruleSort rules)
+
+-- | Solution to day 5 part 2
+-- Example:
+-- >>> solution2 exampleInput
+-- 123
+solution2 :: String -> Integer
+solution2 s = sum $ map middleNumber fixedUps
+ where
+ (rules, updates) = splitParsed $ parse s
+ incorrectUps = filter (not . updateFollowsOrdering rules) updates
+ fixedUps = map (findCorrectOrder rules) incorrectUps
+
+solution :: IO (SolType, SolType)
+solution = do
+ probStr <- input
+ let sol1 = solution1 probStr
+ let sol2 = solution2 probStr
+ return (IntSol sol1, IntSol sol2)
diff --git a/src/Solutions.hs b/src/Solutions.hs
@@ -4,13 +4,15 @@ import qualified Day1 (solution)
import qualified Day2 (solution)
import qualified Day3 (solution)
import qualified Day4 (solution)
+import qualified Day5 (solution)
import Utils (SolType)
solutions :: [(Integer, IO (SolType, SolType))]
-solutions = [
- (1, Day1.solution),
- (2, Day2.solution),
- (3, Day3.solution),
- (4, Day4.solution)
- ]
+solutions =
+ [ (1, Day1.solution)
+ , (2, Day2.solution)
+ , (3, Day3.solution)
+ , (4, Day4.solution)
+ , (5, Day5.solution)
+ ]
diff --git a/test/Main.hs b/test/Main.hs
@@ -21,4 +21,5 @@ main = do
, "src/Day2.hs"
, "src/Day3.hs"
, "src/Day4.hs"
+ , "src/Day5.hs"
] ++ packageDbOption
