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