AOC 5

Solve.hs

import Data.List (sort)

data Range = Range {start :: !Int, end :: !Int}
    deriving (Show, Eq, Ord)
type Mapping = [(Range, Range)] -- ^ source -> dest, not like reqs

pipe :: [Mapping] -> Int -> Int
pipe [] val = val
pipe (mapping:maps) val = case filter (rangeElem val . fst) mapping of
    [(source, dest)] -> pipe maps $! val - start source + start dest
    [] -> pipe maps val -- identity range
    _ -> error "pipe: overlapping ranges"

rangeElem x range = start range <= x && x <= end range

pipeRangeOnce :: Mapping -> Range -> [Range]
pipeRangeOnce mapping range@(Range s e) =
    let leftOverlap = map cull . filter (\(r, _) -> start r < s && end r `rangeElem` range) $ mapping
        rightOverlap = map cull . filter (\(r, _) -> start r `rangeElem` range && e < end r) $ mapping
        middle = sort . filter (\(r, _) -> start r `rangeElem` range && end r `rangeElem` range) $ mapping
        -- at first I forgot about this case. Double cull to cull start and end
        consuming = map (cull . cull) . filter (\(r, _) -> s `rangeElem` r && e `rangeElem` r) $ mapping
        -- if there is consuming, it might overlap with left or right, so handle specifically
        matching = leftOverlap <> middle <> rightOverlap
    in case consuming of
        [(_, dest)] -> [dest]
        -- now each matching range is fully in source range. We can use dest ranges, but need to fill the gaps.
        _ -> map snd . fillStart . fillGaps $ matching
    where
        cull (source, dest)
            | start source < s  =
                let diff = s - start source
                in ( source { start = start source + diff }, dest { start = start dest + diff } )
            | e < end source =
                let diff = end source - e
                in ( source { end = end source - diff }, dest { end = end dest - diff } )
            | otherwise  = (source, dest) -- just in case
        --
        fillGaps [] = []
        fillGaps [(x, xDest)]
            -- fill the last gap as well
            | end x < e  =
                let gap = Range { start = end x + 1, end = e }
                in [ (x, xDest), (gap, gap) ]
            | otherwise = [(x, xDest)]
        fillGaps ((x, xDest):(y, yDest):xs)
            | start y - end x <= 1  = (x, xDest) : fillGaps ( (y, yDest) : xs )
            | otherwise  =
                let gap = Range { start = end x + 1, end = start y - 1 }
                in (x, xDest) : (gap, gap) : fillGaps ( (y, yDest) : xs )
        -- fill the first gap as well
        fillStart [] = -- if no mapping range matched, identity it is
            [(range, range)]
        fillStart ( (x, xDest) : xs )
            | start x > s  =
                let gap = Range { start = s, end = start x - 1 }
                in (gap, gap) : (x, xDest) : xs
            | otherwise  = (x, xDest) : xs

pipeRange :: [Mapping] -> Range -> [Range]
pipeRange maps range = go maps [range]
    where
        go [] r = r
        go (m:ms) rs = do
            r <- rs
            let rs' = pipeRangeOnce m r
            go ms rs'

pipeAsRange :: [Mapping] -> Int -> Either [Range] Int
pipeAsRange maps x = case pipeRange maps $ Range x x of
    [Range s e] | s == e -> Right s
    other -> Left other

pipeAsNumbers :: [Mapping] -> Range -> [Int]
pipeAsNumbers maps (Range start end) =
    map (pipe maps) [start..end]



example =
    [ [ (Range 98 99, Range 50 51)
      , (Range 50 97, Range 52 99)
      ]
    , [ (Range 15 51, Range 0 36)
      , (Range 52 53, Range 37 38)
      , (Range 0 14, Range 39 53)
      ]
    ]

readMappings :: String -> Either String ([Int], [Mapping])
readMappings input = do
    input <- pure $ lines input
    (seedsLine, input) <- case input of
        seedsLine : "" : rest -> pure (seedsLine, rest)
        _ -> Left "no separator"

    seeds <- case seedsLine of
        's':'e':'e':'d':'s':':':' ':numbers -> pure $ map read . words $ numbers
        _ -> Left "no seeds prefix"

    let categories = splitBy (== "") input
    let readCategory =
            let readLine [destStart, sourceStart, len] =
                    pure (Range sourceStart (sourceStart + len), Range destStart (destStart + len))
                readLine _ = Left "Invalid range mapping line"
            in traverse (readLine . map read . words) . tail

    mappings <- traverse readCategory categories

    pure (seeds, mappings)

seedsToRanges :: [Int] -> [Range]
seedsToRanges [] = []
seedsToRanges (s : l : rest) = Range s (s + l - 1) : seedsToRanges rest

-- | Однажды она появится в стдлибе. Тем более что эта версия бажная
splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy p [] = []
splitBy p xs =
    let (h, t) = span (not . p) xs
    in h : splitBy p (tail' t)
    where
        tail' [] = []
        tail' (a:as) = as

transcript

Transcript of ghci session running the solution

GHCi, version 9.4.7: https://www.haskell.org/ghc/  :? for help
[1 of 1] Compiling Morj_Ghci_Prompt ( /home/morj/.ghc/Morj_Ghci_Prompt.hs, interpreted )
Ok, one module loaded.
Loaded GHCi configuration from /home/morj/.vim/dotfiles/ghc/ghci.conf
Prelude
λ :load Solve.hs 
[1 of 2] Compiling Main             ( Solve.hs, interpreted )
Ok, one module loaded.
*Main
λ file <- readFile "input.txt"
*Main
λ let Right (seeds, maps) = readMappings file
*Main
λ seeds
[2906961955,52237479,1600322402,372221628,2347782594,164705568,541904540,89745770,126821306,192539923,3411274151,496169308,919015581,8667739,654599767,160781040,3945616935,85197451,999146581,344584779]
*Main
λ map (pipe maps) seeds
[3987572099,921052246,989234760,2357516214,1312864011,3086362955,486613012,697066253,3048478693,1740442392,2271416634,673394554,4225564962,877482506,2155158469,3082438427,4082279018,692517934,2020311576,2329879365]
*Main
λ minimum it
486613012

transcript2

Fake transcript of getting a solution.
Steps:
1. Get input data
2. Get input ranges from seeds array (too lazy to rewrite the parser)
3. Pipe all ranges
4. Get the smallest range
5. Its start is the solution

λ file <- readFile "input.txt"
λ let Right (seeds, maps) = readMappings file
λ let inRanges = seedsToRanges seeds
λ start . head . sort . concat . map (pipeRange maps) $ inRanges
56931769