--- Writeup at https://work.njae.me.uk/2023/12/04/advent-of-code-2023-day-04/
+-- Writeup at https://work.njae.me.uk/2023/12/05/advent-of-code-2023-day-05/
import AoC
import Data.Text (Text)
import qualified Data.Text.IO as TIO
import Data.Attoparsec.Text -- hiding (take)
-import Control.Applicative
--- import Data.List
+-- import Control.Applicative
+import Data.List
import qualified Data.Map.Strict as M
import Data.Map.Strict ((!))
-import Data.Maybe
import Data.List.Split (chunksOf)
type Almanac = M.Map String AMap
data AMap = AMap String [Rule] deriving (Eq, Show)
-data Rule = Rule Int Int Int deriving (Eq, Show)
-data Requirement = Requirement String [Int] deriving (Eq, Show)
+data Rule = Rule Interval Int deriving (Eq, Ord, Show)
+data Requirement = Requirement String [Interval] deriving (Eq, Show)
+
+data Interval = Iv Int Int deriving (Eq, Ord, Show) -- inclusive, closed at both ends
main :: IO ()
do dataFileName <- getDataFileName
text <- TIO.readFile dataFileName
let (seeds, almanac) = successfulParse text
- -- print seeds
- -- print almanac
- -- print $ useAMap (almanac ! "seed") [97, 98, 99, 100]
- -- print $ useAMap (almanac ! "seed") [49, 50, 51, 53, 96, 97, 98]
- -- print $ useAMap (almanac ! "seed") [79, 14, 55, 13]
print $ part1 almanac seeds
- -- print $ expandRanges seeds
print $ part2 almanac seeds
- -- print $ part2 cards
-
-part1 :: Almanac -> [Int] -> Int
-part1 = lowestLocation
+
+part1, part2 :: Almanac -> [Int] -> Int
+part1 almanac seeds = lowestLocation almanac seeds'
+ where seeds' = tidyIntervals $ singletonRanges seeds
-part2 almanac seeds = lowestLocation almanac $ expandRanges seeds
+part2 almanac seeds = lowestLocation almanac seeds'
+ where seeds' = tidyIntervals $ expandRanges seeds
-lowestLocation almanac seeds = minimum locations
+lowestLocation :: Almanac -> [Interval] -> Int
+lowestLocation almanac seeds = l
where Requirement _ locations = followRequirements almanac $ Requirement "seed" seeds
+ (Iv l _) = head locations
followRequirements :: Almanac -> Requirement -> Requirement
-followRequirements almanac req@(Requirement "location" vals) = req
+followRequirements _ req@(Requirement "location" _) = req
followRequirements almanac (Requirement name vals) =
followRequirements almanac newReq
where aMap = almanac ! name
newReq = useAMap aMap vals
+useRule :: Rule -> Interval -> ([Interval], [Interval], [Rule])
+useRule (Rule (Iv rl rh) d) (Iv xl xh) = (newResults, newVals, newRules)
+ where newResults =
+ filter legalInterval
+ [ Iv xl (rl - 1) -- input below rule
+ , Iv ((max xl rl) + d) ((min xh rh) + d)] -- input within rule
+ newVals = filter legalInterval
+ [Iv (rh + 1) xh] -- input above rule
+ newRules = filter legalRule
+ [Rule (Iv (xh + 1) rh) d] -- rule above input
+
-useRule :: Int -> Rule -> Maybe Int
-useRule x (Rule dest src rl)
- | x >= src && x < (src + rl) = Just (x + dest - src)
- | otherwise = Nothing
+useRules :: [Rule] -> [Interval] -> [Interval]
+useRules [] vals = vals
+useRules _ [] = []
+useRules (r@(Rule rv _):rs) (v:vs)
+ | rv `allBelow` v = useRules rs (v:vs)
+ | v `allBelow` rv = v : useRules (r:rs) vs
+ | otherwise = newResults ++ (useRules (newRules ++ rs) (newVals ++ vs))
+ where (newResults, newVals, newRules) = useRule r v
-useRules :: [Rule] -> Int -> Int
-useRules rs x
- | null ruleResults = x
- | otherwise = head ruleResults
- where ruleResults = catMaybes $ fmap (useRule x) rs
+legalInterval :: Interval -> Bool
+legalInterval (Iv l h) = l <= h
-useAMap :: AMap -> [Int] -> Requirement
-useAMap (AMap d rs) xs = Requirement d $ fmap (useRules rs) xs
+legalRule :: Rule -> Bool
+legalRule (Rule iv _) = legalInterval iv
+useAMap :: AMap -> [Interval] -> Requirement
+useAMap (AMap d rs) xs = Requirement d $ tidyIntervals $ useRules rs xs
-expandRanges :: [Int] -> [Int]
-expandRanges seeds = concatMap expandRange ranges
+
+singletonRanges :: [Int] -> [Interval]
+singletonRanges = fmap (\x -> Iv x x)
+
+expandRanges :: [Int] -> [Interval]
+expandRanges seeds = fmap expandRange ranges
where ranges = chunksOf 2 seeds
- expandRange [s, l] = [s..(s + l - 1)]
+ expandRange [s, l] = Iv s (s + l - 1)
+
+
+tidyIntervals :: [Interval] -> [Interval]
+tidyIntervals = tidyIntervalsS . sort
+
+tidyIntervalsS :: [Interval] -> [Interval]
+tidyIntervalsS [] = []
+tidyIntervalsS [x] = [x]
+tidyIntervalsS (x:y:xs)
+ | x `allBelow` y = x : tidyIntervalsS (y:xs)
+ | otherwise = tidyIntervalsS ((x `merge` y) : xs)
+
+allBelow :: Interval -> Interval -> Bool
+allBelow (Iv _ x2) (Iv y1 _) = (x2 + 1) < y1
+
+merge :: Interval -> Interval -> Interval
+merge (Iv x1 x2) (Iv y1 y2) = Iv (min x1 y1) (max x2 y2)
+
-- Parse the input file
aMapHeaderP = (,) <$> (nameP <* "-to-") <*> (nameP <* " map:" <* endOfLine)
rulesP = ruleP `sepBy` endOfLine
-ruleP = Rule <$> (decimal <* space) <*> (decimal <* space) <*> decimal
+ruleP = ruleify <$> (decimal <* space) <*> (decimal <* space) <*> decimal
numbersP = decimal `sepBy` skipSpace
nameP = many1 letter
blankLineP = endOfLine *> endOfLine
aMapify :: (String, String) -> [Rule] -> (String, AMap)
-aMapify (s, d) rs = (s, AMap d rs)
+aMapify (s, d) rs = (s, AMap d (sort rs))
+
+ruleify :: Int -> Int -> Int -> Rule
+ruleify d s l = Rule (Iv s (s + l - 1)) (d - s)
successfulParse :: Text -> ([Int], Almanac)
successfulParse input =