Done day 22
[advent-of-code-23.git] / advent05 / Main.hs
1 -- Writeup at https://work.njae.me.uk/2023/12/05/advent-of-code-2023-day-05/
2
3 import AoC
4 import Data.Text (Text)
5 import qualified Data.Text.IO as TIO
6 import Data.Attoparsec.Text -- hiding (take)
7 -- import Control.Applicative
8 import Data.List
9 import qualified Data.Map.Strict as M
10 import Data.Map.Strict ((!))
11 import Data.List.Split (chunksOf)
12
13 type Almanac = M.Map String AMap
14 data AMap = AMap String [Rule] deriving (Eq, Show)
15 data Rule = Rule Interval Int deriving (Eq, Ord, Show)
16 data Requirement = Requirement String [Interval] deriving (Eq, Show)
17
18 data Interval = Iv Int Int deriving (Eq, Ord, Show) -- inclusive, closed at both ends
19
20
21 main :: IO ()
22 main =
23 do dataFileName <- getDataFileName
24 text <- TIO.readFile dataFileName
25 let (seeds, almanac) = successfulParse text
26 print $ part1 almanac seeds
27 print $ part2 almanac seeds
28
29 part1, part2 :: Almanac -> [Int] -> Int
30 part1 almanac seeds = lowestLocation almanac seeds'
31 where seeds' = tidyIntervals $ singletonRanges seeds
32
33 part2 almanac seeds = lowestLocation almanac seeds'
34 where seeds' = tidyIntervals $ expandRanges seeds
35
36 lowestLocation :: Almanac -> [Interval] -> Int
37 lowestLocation almanac seeds = l
38 where Requirement _ locations = followRequirements almanac $ Requirement "seed" seeds
39 (Iv l _) = head locations
40
41 followRequirements :: Almanac -> Requirement -> Requirement
42 followRequirements _ req@(Requirement "location" _) = req
43 followRequirements almanac (Requirement name vals) =
44 followRequirements almanac newReq
45 where aMap = almanac ! name
46 newReq = useAMap aMap vals
47
48
49 useRule :: Rule -> Interval -> ([Interval], [Interval], [Rule])
50 useRule (Rule (Iv rl rh) d) (Iv xl xh) = (newResults, newVals, newRules)
51 where newResults =
52 filter legalInterval
53 [ Iv xl (rl - 1) -- input below rule
54 , Iv ((max xl rl) + d) ((min xh rh) + d)] -- input within rule
55 newVals = filter legalInterval
56 [Iv (rh + 1) xh] -- input above rule
57 newRules = filter legalRule
58 [Rule (Iv (xh + 1) rh) d] -- rule above input
59
60
61 useRules :: [Rule] -> [Interval] -> [Interval]
62 useRules [] vals = vals
63 useRules _ [] = []
64 useRules (r@(Rule rv _):rs) (v:vs)
65 | rv `allBelow` v = useRules rs (v:vs)
66 | v `allBelow` rv = v : useRules (r:rs) vs
67 | otherwise = newResults ++ (useRules (newRules ++ rs) (newVals ++ vs))
68 where (newResults, newVals, newRules) = useRule r v
69
70 legalInterval :: Interval -> Bool
71 legalInterval (Iv l h) = l <= h
72
73 legalRule :: Rule -> Bool
74 legalRule (Rule iv _) = legalInterval iv
75
76 useAMap :: AMap -> [Interval] -> Requirement
77 useAMap (AMap d rs) xs = Requirement d $ tidyIntervals $ useRules rs xs
78
79
80 singletonRanges :: [Int] -> [Interval]
81 singletonRanges = fmap (\x -> Iv x x)
82
83 expandRanges :: [Int] -> [Interval]
84 expandRanges seeds = fmap expandRange ranges
85 where ranges = chunksOf 2 seeds
86 expandRange [s, l] = Iv s (s + l - 1)
87
88
89 tidyIntervals :: [Interval] -> [Interval]
90 tidyIntervals = tidyIntervalsS . sort
91
92 tidyIntervalsS :: [Interval] -> [Interval]
93 tidyIntervalsS [] = []
94 tidyIntervalsS [x] = [x]
95 tidyIntervalsS (x:y:xs)
96 | x `allBelow` y = x : tidyIntervalsS (y:xs)
97 | otherwise = tidyIntervalsS ((x `merge` y) : xs)
98
99 allBelow :: Interval -> Interval -> Bool
100 allBelow (Iv _ x2) (Iv y1 _) = (x2 + 1) < y1
101
102 merge :: Interval -> Interval -> Interval
103 merge (Iv x1 x2) (Iv y1 y2) = Iv (min x1 y1) (max x2 y2)
104
105
106
107 -- Parse the input file
108
109 problemP :: Parser ([Int], Almanac)
110 seedsP :: Parser [Int]
111 almanacP :: Parser Almanac
112 aMapP :: Parser (String, AMap)
113 aMapHeaderP :: Parser (String, String)
114 rulesP :: Parser [Rule]
115 ruleP :: Parser Rule
116 numbersP :: Parser [Int]
117 nameP :: Parser String
118 blankLineP :: Parser ()
119
120
121 problemP = (,) <$> (seedsP <* blankLineP) <*> almanacP
122
123 seedsP = "seeds: " *> numbersP
124
125 almanacP = M.fromList <$> (aMapP `sepBy` blankLineP)
126
127 aMapP = aMapify <$> aMapHeaderP <*> rulesP
128 aMapHeaderP = (,) <$> (nameP <* "-to-") <*> (nameP <* " map:" <* endOfLine)
129
130 rulesP = ruleP `sepBy` endOfLine
131 ruleP = ruleify <$> (decimal <* space) <*> (decimal <* space) <*> decimal
132
133 numbersP = decimal `sepBy` skipSpace
134 nameP = many1 letter
135
136 blankLineP = endOfLine *> endOfLine
137
138 aMapify :: (String, String) -> [Rule] -> (String, AMap)
139 aMapify (s, d) rs = (s, AMap d (sort rs))
140
141 ruleify :: Int -> Int -> Int -> Rule
142 ruleify d s l = Rule (Iv s (s + l - 1)) (d - s)
143
144 successfulParse :: Text -> ([Int], Almanac)
145 successfulParse input =
146 case parseOnly problemP input of
147 Left _err -> ([], M.empty) -- TIO.putStr $ T.pack $ parseErrorPretty err
148 Right matches -> matches