day 5

Signed-off-by: Amneesh Singh <natto@weirdnatto.in>

day05.hs

@@ -0,0 +1,84 @@
+import Data.Either (rights)
+import Data.List (find)
+import Data.Map qualified as M
+import Data.Maybe (maybe)
+import Data.Text qualified as T
+import Lib (readFile', split)
+import Text.Parsec
+
+data Mapping = Mapping {dst :: Int, src :: Int, range :: Int}
+
+data Range = Range {start :: Int, end :: Int}
+
+-- i hate this so much
+
+main :: IO ()
+main = do
+  (seedsRaw : _ : mapsRaw') <- T.lines <$> readFile' "day05.in"
+  let mapsRaw = split T.empty mapsRaw'
+  let Right seeds = parse parseSeeds "" seedsRaw
+  let maps = parseMaps mapsRaw
+  putStr "Q1: "
+  print . minimum . map (\x -> start . head $ search "seed" maps Range {start = x, end = x}) $ seeds
+  putStr "Q2: "
+  print . minimum . map (minimum . map start . search "seed" maps) $ seedRanges seeds
+  where
+    seedRanges :: [Int] -> [Range]
+    seedRanges [] = []
+    seedRanges (start : range : xs) = Range {start, end = start + range - 1} : seedRanges xs
+
+search :: String -> M.Map String (String, [Mapping]) -> Range -> [Range]
+search from m r
+  | to == "location" = mapped
+  | otherwise = concatMap (search to m) mapped
+  where
+    Just (to, mappings) = M.lookup from m
+    mapped = search' r mappings
+
+-- TODO: make this less scuffed (?)
+search' :: Range -> [Mapping] -> [Range]
+search' r@Range {start, end} mappings =
+  maybe
+    [r]
+    (mapRange r)
+    (find (\Mapping {dst, src, range} -> start < src + range && end >= src) mappings)
+  where
+    mapRange :: Range -> Mapping -> [Range]
+    mapRange r@Range {start, end} Mapping {dst, src, range}
+      -- For [] = search range, () = mapping
+      --  [___(__]___)
+      | start < src && end < src + range = Range {start = dst, end = dst + end - src} : search' Range {start, end = src - 1} mappings
+      --  (__[____]__)
+      | start >= src && end < src + range = [Range {start = dst + start - src, end = dst + end - src}]
+      --  (___[__)___]
+      | start >= src && end >= src + range = Range {start = dst + start - src, end = dst + range - 1} : search' Range {start = src + range, end} mappings
+      --  [__(____)__]
+      | start <= src && end >= src + range = Range {start = dst, end = dst + range - 1} : (search' Range {start, end = src - 1} mappings <> search' Range {start = src + range, end} mappings)
+
+-- Parsing --
+
+parseSeeds :: (Stream s m Char) => ParsecT s u m [Int]
+parseSeeds = do
+  string "seeds: "
+  seed <- many1 digit `sepBy` space
+  return $ read <$> seed
+
+parseMaps = foldr parseMaps' M.empty
+  where
+    parseMaps' :: [T.Text] -> M.Map String (String, [Mapping]) -> M.Map String (String, [Mapping])
+    parseMaps' (x : xs) m =
+      let Right (from, to) = parse parseHead "" x
+          mappings = rights $ map (parse parseMapping "") xs
+       in M.insert from (to, mappings) m
+
+parseHead :: (Stream s m Char) => ParsecT s u m (String, String)
+parseHead = do
+  [from, "to", to] <- many1 letter `sepBy` char '-'
+  string " map:"
+  return (from, to)
+
+parseMaps :: [[T.Text]] -> M.Map String (String, [Mapping])
+parseMapping :: (Stream s m Char) => ParsecT s u m Mapping
+parseMapping = do
+  [dst, src, range] <- (read <$> many1 digit) `sepBy` space
+  return $ Mapping {dst, src, range}