day 15: rewrite part 2

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

README

@@ -0,0 +1 @@
+My advent of code solutions for 2022. I am trying to not use String ([Char]) wherever possible and use Data.Text instead. That makes the programs appear bigger than they are LOC-wise.

day09.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.List (nub, scanl)
+import Data.Text (Text)
+import qualified Data.Text as T (lines, unpack, words)
+import qualified Data.Text.Read as T (decimal)
+import Lib (readFile')
+
+-- a rather slow program, takes 300 ms on my system (with `time`, but idc anymore 😭
+
+main :: IO ()
+main = do
+  input <-
+    concatMap
+      ((\[T.unpack -> [d], T.decimal -> Right (n, "")] -> replicate n d) . T.words)
+      . T.lines
+      <$> readFile' "day9.in"
+  putStr "Q1: "
+  print $ q 1 input
+  putStr "Q2: "
+  print $ q 9 input
+
+moveHead :: Char -> (Int, Int) -> (Int, Int)
+moveHead d (x, y) = case d of
+  'L' -> (x - 1, y)
+  'R' -> (x + 1, y)
+  'U' -> (x, y + 1)
+  'D' -> (x, y - 1)
+
+moveTail :: (Int, Int) -> (Int, Int) -> (Int, Int)
+moveTail (hx, hy) (tx, ty)
+  | abs dx <= 1 && abs dy <= 1 = (tx, ty) -- dont move
+  | abs dx > abs dy = (tx + signum dx, hy) -- move horizontally
+  | abs dy > abs dx = (hx, ty + signum dy) -- move vertically
+  | otherwise = (tx + signum dx, ty + signum dy ) -- move diagonally
+  where
+    dx = hx - tx
+    dy = hy - ty
+
+q :: Int -> [Char] -> Int
+q n =
+  length . nub . map last
+    . scanl
+      ( \(h : t) d ->
+          reverse $ foldl (\(h : xs) x -> moveTail h x : (h : xs)) [moveHead d h] t
+      )
+      (replicate (n + 1) (0, 0))

day10.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.Text (Text)
+import qualified Data.Text as T (lines, pack, unlines, words)
+import qualified Data.Text.IO as T (putStr)
+import qualified Data.Text.Read as T (decimal, signed)
+import Lib (readFile')
+
+main :: IO ()
+main = do
+  vals <-
+    scanl1 (+)
+      . reverse
+      . foldl
+        ( \xs x ->
+            let o : n = T.words x
+                dec (T.signed T.decimal . head -> Right (m, "")) = m
+             in if o == "noop" then 0 : xs else dec n : 0 : xs
+        )
+        [1]
+      . T.lines
+      <$> readFile' "day10.in"
+  putStr "Q1: "
+  print $ q1 vals
+  putStrLn "Q2: "
+  T.putStr $ q2 vals
+
+q1 :: [Int] -> Int
+q1 v = foldr (\x xs -> xs + (v !! (x - 1) * x)) 0 [20, 60 .. 220]
+
+q2 :: [Int] -> Text
+q2 v =
+  T.unlines $
+    map
+      ( \x ->
+          T.pack $
+            map (\y -> if abs (v !! (x + y) - y) <= 1 then '#' else '.') [0 .. 39]
+      )
+      [0, 40 .. 200]

day11.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.Either (rights)
+import Data.List (sortOn)
+import Data.Map (Map)
+import qualified Data.Map as M (elems, fromList, insert, keys, lookup, update)
+import Data.Maybe (fromJust)
+import Data.Ord (Down (Down))
+import Data.Text (Text)
+import qualified Data.Text as T (empty, init, lines, stripSuffix, words)
+import qualified Data.Text.Read as T (decimal, signed)
+import Lib (readFile')
+import Prelude hiding (round)
+
+-- again a slow program ;-; takes 410 ms when measured with `time`
+
+main :: IO ()
+main = do
+  input <- parse . T.lines <$> readFile' "day11.in"
+  putStr "Q1: "
+  print $ q 3 20 input
+  putStr "Q2: "
+  print $ q 1 10000 input
+
+data Monkey = Banana
+  { items :: [Int],
+    operation :: Int -> Int -> Int,
+    factor :: Int,
+    next :: (Int, Int),
+    iCount :: Int
+  }
+
+q :: Int -> Int -> Map Int Monkey -> Int
+q d n =
+  product . take 2
+    . sortOn Down
+    . map iCount
+    . M.elems
+    . (!! n)
+    . iterate (round d)
+
+round :: Int -> Map Int Monkey -> Map Int Monkey
+round d monkeys =
+  foldl
+    ( \m k ->
+        let (Banana items op f (a, b) c) = fromJust $ M.lookup k m
+         in M.insert k (Banana [] op f (a, b) (c + length items)) $
+              foldr
+                ( \x m ->
+                    let worry = op x d `mod` divisor
+                     in M.update
+                          ( Just
+                              . ( \(Banana items' op' f' n' c') ->
+                                    Banana (worry : items') op' f' n' c'
+                                )
+                          )
+                          (if worry `mod` f == 0 then a else b)
+                          m
+                )
+                m
+                items
+    )
+    monkeys
+    (M.keys monkeys)
+  where
+    divisor :: Int
+    divisor = foldr1 lcm (map factor $ M.elems monkeys)
+
+parse :: [Text] -> Map Int Monkey
+parse =
+  M.fromList
+    . map
+      ( \( (parseMonkey -> n)
+             : (parseItems -> xs)
+             : (parseOp -> op)
+             : (parseTest -> (f, a, b))
+           ) -> (n, Banana xs op f (a, b) 0)
+      )
+    . sLines
+  where
+    parseMonkey :: Text -> Int
+    parseMonkey (T.words -> ["Monkey", T.decimal . T.init -> Right (n, "")]) = n
+
+    parseItems :: Text -> [Int]
+    parseItems (T.words -> "Starting" : "items:" : xs) =
+      map (\(T.decimal -> Right (n, _)) -> n) xs
+
+    parseOp :: Text -> (Int -> Int -> Int)
+    parseOp (T.words -> ["Operation:", "new", "=", e1, o, e2]) =
+      \x d -> div (parseO o (parseE x e1) (parseE x e2)) d
+      where
+        parseO o = if o == "+" then (+) else (*)
+        parseE x e = case T.decimal e of
+          Right (n, "") -> n
+          Left _ -> x
+
+    parseTest :: [Text] -> (Int, Int, Int)
+    parseTest
+      [ T.words -> ["Test:", "divisible", "by", T.decimal -> Right (t, "")],
+        T.words -> ["If", "true:", "throw", "to", "monkey", T.decimal -> Right (a, "")],
+        T.words -> ["If", "false:", "throw", "to", "monkey", T.decimal -> Right (b, "")]
+        ] = (t, a, b)
+
+    sLines :: [Text] -> [[Text]]
+    sLines [] = []
+    sLines input =
+      let (cur, rest) = break (== T.empty) input
+       in cur : sLines (drop 1 rest)

day12.hs

@@ -0,0 +1,77 @@
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+
+import Control.Monad (ap)
+import Data.Map (Map)
+import qualified Data.Map as M (filter, fromList, keys, (!), (!?))
+import Data.Set (Set)
+import qualified Data.Set as S (deleteAt, elemAt, empty, fromList, insert, member, null, singleton, union)
+import Data.Text (Text)
+import qualified Data.Text as T (lines, unpack)
+import Lib (readFile')
+
+main :: IO ()
+main = do
+  input <- parse . T.lines <$> readFile' "day12.in"
+  print $ head . M.keys $ M.filter (== S) input
+  putStr "Q1: "
+  print $ shortest (S.singleton (0, head . M.keys $ M.filter (== S) input)) input E
+  putStr "Q2: "
+  print $
+    shortest
+      ( S.fromList
+          ( zip
+              (repeat 0)
+              (M.keys $ M.filter (\x -> x == S || x == height 'a') input)
+          )
+      )
+      input
+      E
+
+data Height = Height Int | S | E deriving (Show, Eq)
+
+-- no need to implement toEnum
+instance Enum Height where
+  fromEnum S = 0
+  fromEnum E = 25
+  fromEnum (Height h) = h
+
+height :: Char -> Height
+height 'E' = E
+height 'S' = S
+height c = Height $ fromEnum c - fromEnum 'a'
+
+parse :: [Text] -> Map (Int, Int) Height
+parse =
+  M.fromList . concat
+    . zipWith zip (map (\x -> zip (repeat x) [0 ..]) [0 ..])
+    . map (map height . T.unpack)
+
+nextPos :: (Int, Int) -> Map (Int, Int) Height -> [(Int, Int)]
+nextPos (x, y) m = filter check [(x + 1, y), (x - 1, y), (x, y + 1), (x, y - 1)]
+  where
+    check :: (Int, Int) -> Bool
+    check (x', y') =
+      maybe
+        False
+        (<= (succ . fromEnum $ m M.! (x, y)))
+        (fromEnum <$> m M.!? (x', y'))
+
+-- using set as a queue cuz yh
+shortest :: Set (Int, (Int, Int)) -> Map (Int, Int) Height -> Height -> Int
+shortest queue graph end = bfs queue S.empty
+  where
+    bfs :: Set (Int, (Int, Int)) -> Set (Int, Int) -> Int
+    bfs queue vis
+      | graph M.! (x, y) == end = now
+      | otherwise = bfs newqueue (S.insert (x, y) vis)
+      where
+        (now, (x, y)) = S.elemAt 0 queue
+        newqueue =
+          S.union
+            (S.deleteAt 0 queue)
+            ( S.fromList
+                ( zip
+                    (repeat (now + 1))
+                    (filter (not . flip S.member vis) $ nextPos (x, y) graph)
+                )
+            )

day13.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.Char (isDigit)
+import Data.List (elemIndex, sort)
+import Data.Maybe (fromJust)
+import Data.Text (Text)
+import qualified Data.Text as T (filter, init, lines, null, span, tail, uncons)
+import qualified Data.Text.Read as T (decimal)
+import Lib (readFile')
+
+main :: IO ()
+main = do
+  input <-
+    map (fst . parse (List []) . T.init . T.tail) . filter (not . T.null)
+      . T.lines
+      <$> readFile' "day13.in"
+  putStr "Q1: "
+  print $ q1 input
+  putStr "Q2: "
+  print $ q2 input (List [List [Elem 2]]) (List [List [Elem 6]])
+
+q1 :: [List] -> Int
+q1 input =
+  foldl
+    (\xs x -> xs + if input !! (2 * x - 2) < input !! (2 * x - 1) then x else 0)
+    0
+    [1 .. length input `div` 2]
+
+q2 :: [List] -> List -> List -> Int
+q2 input a b =
+  let sorted = sort (a : b : input)
+      a' = fromJust $ elemIndex a sorted
+      b' = fromJust $ elemIndex b sorted
+   in (a' + 1) * (b' + 1)
+
+data List = Elem Int | List [List] deriving (Show, Eq)
+
+-- is this cheating :P
+instance Ord List where
+  compare (List xs) (List ys) = compare (reverse xs) (reverse ys)
+  compare (List xs) (Elem y) = compare (List xs) (List [Elem y])
+  compare (Elem x) (List ys) = compare (List [Elem x]) (List ys)
+  compare (Elem x) (Elem y) = compare x y
+
+-- Weak parser but it works
+-- I do not really know how to use Parsec and ReadP with Data.Text yet
+
+parse :: List -> Text -> (List, Text)
+parse (List xs) txt
+  | T.null txt || cur == ']' = (List xs, rest)
+  | cur == '[' =
+    let (new, next) = parse (List []) rest
+     in parse (List (new : xs)) next
+  | isDigit cur = parse (List (Elem num : xs)) rest'
+  | otherwise = parse (List xs) rest
+  where
+    (cur, rest) = fromJust $ T.uncons txt
+    (T.decimal -> Right (num, ""), rest') = T.span isDigit txt

day14.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.Maybe (fromJust)
+import Data.Set (Set)
+import qualified Data.Set as S (fromList, insert, map, member, notMember, union)
+import Data.Text (Text)
+import qualified Data.Text as T (lines, splitOn, words)
+import qualified Data.Text.Read as T (decimal)
+import Lib (readFile')
+
+-- times can be improved greatly using Data.HashSet in unordered-containers, but i wont use it
+
+main :: IO ()
+main = do
+  input <- parse . T.lines <$> readFile' "day14.in"
+  let mx = maximum $ S.map snd input
+  putStr "Q1: "
+  print $ sand (500, 0) input 0 mx Q1
+  putStr "Q2: "
+  print $ sand (500, 0) input 0 (mx + 2) Q2
+
+type Coord = (Int, Int)
+
+data Q = Q1 | Q2 deriving (Eq)
+
+sand :: Coord -> Set Coord -> Int -> Int -> Q -> Int
+sand (x, y) rocks soFar mx q
+  | (q == Q1 && y > mx) || S.member (x, y) rocks = soFar
+  | q == Q2 && y + 1 == mx = sand (500, 0) (S.insert (x, y) rocks) (soFar + 1) mx q
+  | S.notMember (x, y + 1) rocks = sand (x, y + 1) rocks soFar mx q
+  | S.notMember (x - 1, y + 1) rocks = sand (x - 1, y + 1) rocks soFar mx q
+  | S.notMember (x + 1, y + 1) rocks = sand (x + 1, y + 1) rocks soFar mx q
+  | otherwise = sand (500, 0) (S.insert (x, y) rocks) (soFar + 1) mx q
+
+parse :: [Text] -> Set Coord
+parse =
+  S.fromList
+    . concatMap
+      ( ranges
+          . map
+            ( (\[x, y] -> (x, y))
+                . map (\(T.decimal -> Right (n, "")) -> n)
+                . T.splitOn ","
+            )
+          . filter (/= "->")
+          . T.words
+      )
+  where
+    ranges :: [Coord] -> [Coord]
+    ranges xs =
+      foldr
+        ( \((a, b), (x, y)) z ->
+            if a == x
+              then zip (repeat a) [min b y .. max b y] ++ z
+              else zip [min a x .. max a x] (repeat b) ++ z
+        )
+        []
+        (zip xs (tail xs))

day15.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.List (nub, sort)
+import Data.Maybe (catMaybes)
+import Data.Text (Text)
+import qualified Data.Text as T (lines, null, split)
+import qualified Data.Text.Read as T (decimal, signed)
+import Lib (readFile')
+
+main :: IO ()
+main = do
+  input <- map parse . T.lines <$> readFile' "day15.in"
+  putStr "Q1: "
+  print $ q1 input 2000000
+  putStr "Q2: "
+  print $ q2 input 0 4000000
+
+type Coords = (Int, Int, Int, Int, Int)
+
+q1 :: [Coords] -> Int -> Int
+q1 input n = mergeRanges getRanges
+  where
+    mergeRanges :: [(Int, Int)] -> Int
+    mergeRanges [(x0, x1)] = x1 - x0 + 1
+    mergeRanges ((x0, x1) : (x2, x3) : xs)
+      | x2 - x1 < 2 = mergeRanges $ (x0, max x1 x3) : xs
+      | otherwise = x1 - x0 + 1 + mergeRanges ((x2, x3) : xs)
+
+    getRanges :: [(Int, Int)]
+    getRanges =
+      sort $
+        foldr
+          ( \(x, y, r, a, b) xs -> case r - abs (n - y) of
+              dx
+                | dx < 0 -> xs
+                | n == b -> (x - dx, a - 1) : (a + 1, x + dx) : xs
+                | otherwise -> (x - dx, x + dx) : xs
+          )
+          []
+          input
+
+type Segment = (Int, Int, Int, Int)
+
+q2 input mn mx =
+  head
+    [ a * mx + b
+      | (a, b) <- diag1234,
+        a >= mn && b >= mn && a <= mx && b <= mx,
+        and [abs (b - y) + abs (a - x) > r | (x, y, r, _, _) <- input]
+    ]
+  where
+    diag1, diag2, diag3, diag4 :: Coords -> Segment
+    diag1 (x, y, r, _, _) = (x - r - 1, y, x, y - r - 1)
+    diag2 (x, y, r, _, _) = (x, y - r - 1, x + r + 1, y)
+    diag3 (x, y, r, _, _) = (x, y + r + 1, x + r + 1, y)
+    diag4 (x, y, r, _, _) = (x - r - 1, y, x, y + r + 1)
+
+    diagInt :: Segment -> Segment -> Maybe Segment
+    diagInt a@(x0, y0, x1, y1) b@(x2, y2, x3, y3)
+      | x3 < x0 || x1 < x2 = Nothing
+      | x0 >= x2 && x1 <= x3 = Just a
+      | x2 >= x0 && x3 <= x1 = Just b
+      | x3 >= x1 = Just (x2, y2, x1, y1)
+      | x1 >= x3 = Just (x0, y0, x3, y3)
+
+    diag13, diag24 :: [Segment]
+    diag13 =
+      catMaybes
+        [ diagInt i j
+          | a <- input,
+            b <- input,
+            let i@(x0, y0, x1, y1) = diag1 a,
+            let j@(x2, y2, x3, y3) = diag3 b,
+            a /= b,
+            x0 + y0 == x2 + y2
+        ]
+    diag24 =
+      catMaybes
+        [ diagInt i j
+          | a <- input,
+            b <- input,
+            let i@(x0, y0, x1, y1) = diag2 a,
+            let j@(x2, y2, x3, y3) = diag4 b,
+            a /= b,
+            y0 - x0 == y2 - x2
+        ]
+
+    diag1234 :: [(Int, Int)]
+    diag1234 =
+      [ let (c1, c2) = (y0 + x0, y2 - x2) in (div (c1 - c2) 2, div (c1 + c2) 2)
+        | (x0, y0, x1, y1) <- diag13,
+          (x2, y2, x3, y3) <- diag24
+      ]
+
+parse :: Text -> Coords
+parse =
+  ( \[ "Sensor",
+       "at",
+       "x",
+       T.signed T.decimal -> Right (x, ""),
+       "y",
+       T.signed T.decimal -> Right (y, ""),
+       "closest",
+       "beacon",
+       "is",
+       "at",
+       "x",
+       T.signed T.decimal -> Right (a, ""),
+       "y",
+       T.signed T.decimal -> Right (b, "")
+       ] -> (x, y, abs (b - y) + abs (a - x), a, b)
+  )
+    . filter (not . T.null)
+    . T.split (`elem` (":=, " :: [Char]))