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