advent05/Main.hs

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