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" vals) = 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 [ Iv (min xl rl) (min xh (rl - 1)) -- input below rule
  53                                , Iv ((max xl rl) + d) ((min xh rh) + d)] -- input within rule
  54         newVals = filter legalInterval [Iv (max xl (rh + 1)) (max xh rh)] -- input above rule
  55         newRules = filter legalRule [Rule (Iv (max (xh + 1) rl) (max xh rh)) d] -- rule above input
  56
  57 useRules :: [Rule] -> [Interval] -> [Interval]
  58 useRules [] vals = vals
  59 useRules _ [] = []
  60 useRules (r@(Rule (Iv rl rh) _):rs) (v@(Iv xl xh):vs)
  61   | rh < xl = useRules rs (v:vs)
  62   | xh < rl = v : useRules (r:rs) vs
  63   | otherwise = newResults ++ (useRules (newRules ++ rs) (newVals ++ vs))
  64   where (newResults, newVals, newRules) = useRule r v
  65
  66 legalInterval :: Interval -> Bool
  67 legalInterval (Iv l h) = l <= h
  68
  69 legalRule :: Rule -> Bool
  70 legalRule (Rule iv _) = legalInterval iv
  71
  72 useAMap :: AMap -> [Interval] -> Requirement
  73 useAMap (AMap d rs) xs = Requirement d $ tidyIntervals $ useRules rs xs
  74
  75
  76 singletonRanges :: [Int] -> [Interval]
  77 singletonRanges = fmap (\x -> Iv x x)
  78
  79 expandRanges :: [Int] -> [Interval]
  80 expandRanges seeds = fmap expandRange ranges
  81   where ranges = chunksOf 2 seeds
  82         expandRange [s, l] = Iv s (s + l - 1)
  83
  84
  85 tidyIntervals :: [Interval] -> [Interval]
  86 tidyIntervals ivs0 = tidyIntervalsS $ sort ivs0
  87
  88 tidyIntervalsS :: [Interval] -> [Interval]
  89 tidyIntervalsS [] = []
  90 tidyIntervalsS [x] = [x]
  91 tidyIntervalsS (x:y:xs)
  92   | x `allBelow` y = x : tidyIntervalsS (y:xs)
  93   | otherwise = tidyIntervalsS ((x `merge` y) : xs)
  94
  95 allBelow :: Interval -> Interval -> Bool
  96 allBelow (Iv _ x2) (Iv y1 _) = (x2 + 1) < y1
  97
  98 merge :: Interval -> Interval -> Interval
  99 merge (Iv x1 x2) (Iv y1 y2) = Iv (min x1 y1) (max x2 y2)
 100
 101
 102
 103 -- Parse the input file
 104
 105 problemP :: Parser ([Int], Almanac)
 106 seedsP :: Parser [Int]
 107 almanacP :: Parser Almanac
 108 aMapP :: Parser (String, AMap)
 109 aMapHeaderP :: Parser (String, String)
 110 rulesP :: Parser [Rule]
 111 ruleP :: Parser Rule
 112 numbersP :: Parser [Int]
 113 nameP :: Parser String
 114 blankLineP :: Parser ()
 115
 116
 117 problemP = (,) <$> (seedsP <* blankLineP) <*> almanacP
 118
 119 seedsP = "seeds: " *> numbersP
 120
 121 almanacP = M.fromList <$> (aMapP `sepBy` blankLineP)
 122
 123 aMapP = aMapify <$> aMapHeaderP <*> rulesP
 124 aMapHeaderP = (,) <$> (nameP <* "-to-") <*> (nameP <* " map:" <* endOfLine)
 125
 126 rulesP = ruleP `sepBy` endOfLine
 127 ruleP = ruleify <$> (decimal <* space) <*> (decimal <* space) <*> decimal
 128
 129 numbersP = decimal `sepBy` skipSpace
 130 nameP = many1 letter
 131
 132 blankLineP = endOfLine *> endOfLine
 133
 134 aMapify :: (String, String) -> [Rule] -> (String, AMap)
 135 aMapify (s, d) rs = (s, AMap d (sort rs))
 136
 137 ruleify :: Int -> Int -> Int -> Rule
 138 ruleify d s l = Rule (Iv s (s + l - 1)) (d - s)
 139
 140 successfulParse :: Text -> ([Int], Almanac)
 141 successfulParse input =
 142   case parseOnly problemP input of
 143     Left  _err -> ([], M.empty) -- TIO.putStr $ T.pack $ parseErrorPretty err
 144     Right matches -> matches