day 9

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}

day06.hs

@@ -0,0 +1,25 @@
+data Race = Race {time :: Int, distance :: Int} deriving (Show)
+
+main :: IO ()
+main = do
+  [_ : time', _ : distance'] <- map words . lines <$> readFile "day06.in"
+  
+  let races = zipWith (\t d -> Race {time = read t, distance = read d}) time' distance'
+  let bigRace = Race {time = read $ concat time', distance = read $ concat distance'}
+  
+  putStr "Q1: "
+  print . product . map race $ races
+  putStr "Q2: "
+  print $ race bigRace
+
+-- we need (T - a) * a > D or a^2 - T*a + D < 0 i.e, a quadratic inequality
+race :: Race -> Int
+race Race {time, distance} =
+  let (x, y) = roots
+   in ceiling (x - 1) - floor (y + 1) + 1
+  where
+    -- roots
+    roots :: (Double, Double)
+    roots =
+      let disc = fromIntegral $ time * time - 4 * distance
+       in ((fromIntegral time + sqrt disc) / 2, (fromIntegral time - sqrt disc) / 2)

day07.hs

@@ -0,0 +1,62 @@
+import Data.Char (ord)
+import Data.List (group, nub, sort, sortBy)
+import Data.Ord (comparing)
+import Data.Text qualified as T
+import Lib (count)
+
+-- yes, this is slow
+-- i dont have time for a cuter (and faster) answer :<
+-- Update: I found a solution on reddit that uses some cool default GHC extensions and is much faster, i am not going to use it, but feel free to look it up
+main :: IO ()
+main = do
+  input' <- map words . lines <$> readFile "day07.in"
+  let bids = map (\[x, y] -> (x, read y)) input'
+
+  putStr "Q1: "
+  print
+    . sum
+    . zipWith (*) [1 ..]
+    . map snd
+    . sortBy (comparing (handKind . fst) <> comparing (map strength . fst))
+    $ bids
+
+  putStr "Q2: "
+
+  print
+    . sum
+    . zipWith (*) [1 ..]
+    . map snd
+    . sortBy
+      ( comparing
+          (\(hand, _) -> maximum [handKind (map repl hand) | x <- nub hand, let repl c = if c == 'J' then x else c])
+          <> comparing (map strength2 . fst)
+      )
+    $ bids
+
+strength :: Char -> Int
+strength c = case c of
+  'A' -> 13
+  'K' -> 12
+  'Q' -> 11
+  'J' -> 10
+  'T' -> 9
+  _ -> ord c - ord '1'
+
+strength2 :: Char -> Int
+strength2 c = case c of
+  'A' -> 13
+  'K' -> 12
+  'Q' -> 11
+  'J' -> 0
+  'T' -> 9
+  _ -> ord c - ord '1'
+
+handKind :: String -> Int
+handKind hand = case sort $ map length $ group $ sort hand of
+  [5] -> 6
+  [1, 4] -> 5
+  [2, 3] -> 4
+  [1, 1, 3] -> 3
+  [1, 2, 2] -> 2
+  [1, 1, 1, 2] -> 1
+  _ -> 0

day08.hs

@@ -0,0 +1,44 @@
+import Data.Either (rights)
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Lib (readFile')
+import Text.Parsec
+
+main :: IO ()
+main = do
+  (directionsRaw : _ : mapsRaw) <- T.lines <$> readFile' "day08.in"
+  let directions = cycle $ T.unpack directionsRaw
+  let maps' = rights $ map (parse parseMap "") mapsRaw
+  let maps = M.fromList maps'
+
+  putStr "Q1: "
+  print $ zzz directions maps 0 "AAA"
+
+  putStr "Q2: "
+  print . foldl1 lcm . map (xxz directions maps 0) . filter (\[_, _, c] -> c == 'A') . map fst $ maps'
+
+-- dumb and good recursion
+zzz :: String -> M.Map String (String, String) -> Int -> String -> Int
+zzz (d : ds) m acc str
+  | next == "ZZZ" = acc + 1
+  | otherwise = zzz ds m (acc + 1) next
+  where
+    Just (left, right) = M.lookup str m
+    next = if d == 'L' then left else right
+
+xxz :: String -> M.Map String (String, String) -> Int -> String -> Int
+xxz (d : ds) m acc str
+  | [_, _, 'Z'] <- next = acc + 1
+  | otherwise = xxz ds m (acc + 1) next
+  where
+    Just (left, right) = M.lookup str m
+    next = if d == 'L' then left else right
+
+-- Parsing --
+
+parseMap :: (Stream s m Char) => ParsecT s u m (String, (String, String))
+parseMap = do
+  a <- many1 letter <* string " = ("
+  b <- many1 letter <* string ", "
+  c <- many1 letter <* char ')'
+  return (a, (b, c))

day09.hs

@@ -0,0 +1,22 @@
+import Data.Either (rights)
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Data.Text.Read qualified as TR
+import Lib (readFile', tRead)
+import Text.Parsec
+
+main :: IO ()
+main = do
+  input <- map (map tRead . T.words) . T.lines <$> readFile' "day09.in"
+  
+  putStr "Q1: "
+  print . sum $ map (sum . map last . extrap) input
+  
+  putStr "Q2: "
+  print . sum $ map (sum . map last . extrap . reverse) input
+
+extrap :: [Int] -> [[Int]]
+extrap xs = take (length xs) $ iterate first' xs
+  where
+    first' :: [Int] -> [Int]
+    first' xs = zipWith (-) (tail xs) xs