day 9

very slow very swag Signed-off-by: Amneesh Singh <natto@weirdnatto.in>
2022-12-10 00:18:59 +05:30
17 changed files with 1 additions and 461 deletions
--- a/1
+++ b/1
@@ -1 +0,0 @@
 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.
--- a/day01.hs
+++ b/day01.hs
--- a/day10.hs
+++ b/day10.hs
@@ -1,40 +0,0 @@
 {-# 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]
--- a/day11.hs
+++ b/day11.hs
@@ -1,109 +0,0 @@
 {-# 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)
--- a/day12.hs
+++ b/day12.hs
@@ -1,77 +0,0 @@
 {-# 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)
                )
            )
--- a/day13.hs
+++ b/day13.hs
@@ -1,59 +0,0 @@
 {-# 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
--- a/day14.hs
+++ b/day14.hs
@@ -1,59 +0,0 @@
 {-# 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))
--- a/day15.hs
+++ b/day15.hs
@@ -1,115 +0,0 @@
 {-# 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]))
--- a/day02.hs
+++ b/day02.hs
--- a/day03.hs
+++ b/day03.hs
--- a/day04.hs
+++ b/day04.hs
--- a/day05.hs
+++ b/day05.hs
--- a/day06.hs
+++ b/day06.hs
--- a/day07'.hs
+++ b/day07'.hs
--- a/day07.hs
+++ b/day07.hs
--- a/day08.hs
+++ b/day08.hs
--- a/day09.hs
+++ b/day09.hs
@@ -33,7 +33,7 @@ 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
+  | otherwise = (tx + signum tx, ty + signum dy) -- move diagonally
  where
    dx = hx - tx
    dy = hy - ty
		`@@ -1 +0,0 @@`
			`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.`