day 15: rewrite part 2

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

.envrc

@@ -0,0 +1 @@
+use flake

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.

day05.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.List (foldl')
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Lib (readFile')
+
+main :: IO ()
+main = do
+  input <- break (== T.empty) . T.lines <$> readFile' "day5.in"
+  let (crates, cmds) = parse input
+  putStr "Q1: "
+  print $ moveCrates T.reverse crates cmds
+  putStr "Q2: "
+  print $ moveCrates id crates cmds
+
+moveCrates :: (Text -> Text) -> [Text] -> [(Int, Int, Int)] -> Text
+moveCrates f crates' cmds = head . T.transpose . M.elems $ foldl' move crates cmds
+  where
+    crates :: Map Int Text
+    crates = M.fromList $ zip [0 ..] crates'
+    move :: Map Int Text -> (Int, Int, Int) -> Map Int Text
+    move c (n, x, y) =
+      let (h, t) = T.splitAt n $ c M.! x
+       in M.update (Just . (<>) (f h)) y $ M.insert x t c
+
+-- ugly code vs line length <= 90 🤔
+parse :: ([Text], [Text]) -> ([Text], [(Int, Int, Int)])
+parse (crates, cmds) =
+  ( [ T.filter (/= ' ') x
+      | (i, x) <- zip [0 ..] (T.transpose $ init crates),
+        i `mod` 4 == 1
+    ],
+    map
+      ( ( \["move", T.unpack -> n, "from", T.unpack -> x, "to", T.unpack -> y] ->
+            (read n, read x - 1, read y - 1)
+        )
+          . T.words
+      )
+      $ tail cmds
+  )

day06.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.List (nub)
+import Lib (readFile')
+import Data.Text (Text)
+import qualified Data.Text as T
+
+main :: IO ()
+main = do
+  input <- readFile' "day6.in"
+  putStr "Q1: "
+  print $ parse 4 input
+  putStr "Q2: "
+  print $ parse 14 input
+
+group :: Int -> Text -> [Text]
+group _ "" = []
+group n xs = T.take n xs : group n (T.tail xs)
+
+parse :: Int -> Text -> Int
+parse n = (+ n) . length . takeWhile ((< n) . length) . map (nub . T.unpack) . group n

day07'.hs

@@ -1,8 +1,15 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Either (rights)
+import Data.Text (Text)
+import qualified Data.Text as T (head, lines, words)
+import qualified Data.Text.Read as T (decimal)
 import Data.Tree
+import Lib (readFile')
 
 main :: IO ()
 main = do
-  tree <- snd . flip parse (emptyFs "/") . map words . lines <$> readFile "day7.in"
+  tree <- snd . flip parse (emptyFs "/") . map T.words . T.lines <$> readFile' "day7.in"
   putStr "Q1: "
   print $
     foldTree
@@ -22,24 +29,26 @@ main = do
       )
       tree
 
-type Filesystem = Tree (String, Int)
+type Filesystem = Tree (Text, Int)
 
 tail' :: [a] -> [a]
 tail' = drop 1
 
-emptyFs :: String -> Filesystem
+emptyFs :: Text -> Filesystem
 emptyFs n = Node (n, 0) []
 
-insertFs :: Filesystem -> String -> Filesystem -> Filesystem
+insertFs :: Filesystem -> Text -> Filesystem -> Filesystem
 insertFs (Node n xs) name fs = Node (fst n, snd n + snd (rootLabel fs)) (fs : xs)
 
+ls :: [[Text]] -> [Filesystem]
+ls =
+  map (\[a, b] -> Node (b, fst . head $ rights [T.decimal a]) [])
+    . filter ((/= "dir") . head)
+
 totalSize :: [Filesystem] -> Int
 totalSize = sum . map (snd . rootLabel)
 
-ls :: [[String]] -> [Filesystem]
+parse :: [[Text]] -> Filesystem -> ([[Text]], Filesystem)
-ls = map (\[a, b] -> Node (b, read a) []) . filter ((/= "dir") . head)
-
-parse :: [[String]] -> Filesystem -> ([[String]], Filesystem)
 parse input fs
   | null input || cur == ["$", "cd", ".."] = (tail' input, fs)
   | cur == ["$", "ls"] =
@@ -50,7 +59,7 @@ parse input fs
   | otherwise =
     let name = cur !! 2
         (nextInput, newFs) = parse (tail' input) (emptyFs name)
-        replaced = insertFs fs name newFs -- replace empty directory
+        replaced = insertFs fs name newFs
      in parse nextInput replaced
   where
     cur = head input

day07.hs

@@ -1,12 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Either (rights)
+import Data.Text (Text)
+import qualified Data.Text as T (head, lines, words)
+import qualified Data.Text.Read as T (decimal)
 import Data.Tree
+import Lib (readFile')
 
 -- this solution assumes that empty directories can exist,
 -- if you want to ignore that, there is a slightly different code in day7'.hs
--- needs cleaning and improvement
+
+-- needs cleaning and improvement, although i like the fact
+-- that the entire FS can be printed as a tree
 
 main :: IO ()
 main = do
-  tree <- snd . flip parse (emptyFs "/") . map words . lines <$> readFile "day7.in"
+  tree <- snd . flip parse (emptyFs "/") . map T.words . T.lines <$> readFile' "day7.in"
   putStr "Q1: "
   print $
     foldTree
@@ -26,18 +35,18 @@ main = do
       )
       tree
 
-type Filesystem = Tree (String, Int)
+type Filesystem = Tree (Text, Int)
 
 tail' :: [a] -> [a]
 tail' = drop 1
 
 -- wrapper to create an empty tree
-emptyFs :: String -> Filesystem
+emptyFs :: Text -> Filesystem
 emptyFs n = Node (n, 0) []
 
 -- This function is to replace a filesystem by name
 -- Used to replace empty directories with parsed directories in code
-replaceFs :: Filesystem -> String -> Filesystem -> Filesystem
+replaceFs :: Filesystem -> Text -> Filesystem -> Filesystem
 replaceFs (Node n xs) name fs =
   let (h, t) = span ((/= name) . fst . rootLabel) xs
    in Node
@@ -50,11 +59,17 @@ totalSize :: [Filesystem] -> Int
 totalSize = sum . map (snd . rootLabel)
 
 -- All directories/files are parsed here into leaves
-ls :: [[String]] -> [Filesystem]
+ls :: [[Text]] -> [Filesystem]
-ls = map (\[a, b] -> if a == "dir" then Node (b, 0) [] else Node (b, read a) [])
+ls =
+  map
+    ( \[a, b] ->
+        if a == "dir"
+          then Node (b, 0) []
+          else Node (b, fst . head $ rights [T.decimal a]) []
+    )
 
 -- main function where stuff happens
-parse :: [[String]] -> Filesystem -> ([[String]], Filesystem)
+parse :: [[Text]] -> Filesystem -> ([[Text]], Filesystem)
 parse input fs
   | null input || cur == ["$", "cd", ".."] = (tail' input, fs)
   | cur == ["$", "ls"] =

day08.hs

@@ -0,0 +1,48 @@
+import Data.List (scanl, tails, transpose, zip4, zipWith4)
+import Data.Text (Text)
+import qualified Data.Text as T (lines, unpack)
+import Lib (readFile')
+
+-- new approach was hinted by an anon but I cannot quite get it right
+-- a fun approach, not necessarily the fastest (or cleanest (or smartest))
+
+main :: IO ()
+main = do
+  input <- map T.unpack . T.lines <$> readFile' "day8.in"
+  putStr "Q1: "
+  print $ q1 input
+  putStr "Q2: "
+  print $ q2 input
+
+layer :: [[Char]] -> (a -> a -> a) -> ([[Char]] -> [[a]]) -> [[a]]
+layer input f f' =
+  zipWith4 ( zipWith4 (\w x y z -> f w . f x $ f y z) )
+    (f' e)
+    (map reverse $ f' w)
+    (transpose $ f' n)
+    (reverse . transpose $ f' s)
+  where
+    (e, w, n, s) =
+      ( input,
+        map reverse input,
+        transpose input,
+        transpose $ reverse input
+      ) -- (east, west, north, south]
+
+q1 :: [[Char]] -> Int
+q1 input = length . filter not . concat $ layer input (&&) q1'
+  where
+    q1' :: [[Char]] -> [[Bool]]
+    q1' = map (\x -> zipWith (<=) x $ scanl max minBound x)
+
+q2 :: [[Char]] -> Int
+q2 input = maximum . concat $ layer input (*) q2'
+  where
+    q2' :: [[Char]] -> [[Int]]
+    q2' =
+      map
+        ( \a ->
+            [ let l = length (takeWhile (< x) xs) in (+ l) . fromEnum $ length xs /= l
+              | (x : xs) <- tails a
+            ]
+        )

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]))

day5.hs

@@ -1,44 +0,0 @@
-import Data.Char (isDigit)
-import Data.List (transpose)
-import Data.Maybe (catMaybes)
-import Text.ParserCombinators.ReadP
-
-main :: IO ()
-main = do
-  input <- lines <$> readFile "day5.in"
-  let (crates, cmds) = break null input
-  let cratesList = map catMaybes $ transpose $ map (fst . last . readP_to_S parseCrates) $ init crates
-  let cmdsList = map ((\(n, a, b) -> (n, a - 1, b - 1)) . fst . last . readP_to_S parseCmd) $ tail cmds
-  print cratesList
-  putStr "Q1: "
-  print $ q1 cratesList cmdsList
-  putStr "Q2: "
-  print $ q2 cratesList cmdsList
-
-q1, q2 :: [[Char]] -> [(Int, Int, Int)] -> [Char]
-q1 crates cmds = map head $ foldl (\x xs -> moveCrates x xs True) crates cmds
-q2 crates cmds = map head $ foldl (\x xs -> moveCrates x xs False) crates cmds
-
--- Computers are fast, really, not optimising right now
-moveCrates :: [[Char]] -> (Int, Int, Int) -> Bool -> [[Char]]
-moveCrates crates (n, a, b) rev =
-  let (head, tail) = splitAt n $ crates !! a
-   in replace b (replace a crates tail) ((if rev then reverse head else head) ++ crates !! b)
-  where
-    replace :: Int -> [a] -> a -> [a]
-    replace i xs x = take i xs ++ [x] ++ drop (i + 1) xs
-
-parseCrates :: ReadP [Maybe Char]
-parseCrates = sepBy parseRow (char ' ')
-  where
-    parseRow :: ReadP (Maybe Char)
-    parseRow = (Just <$> (char '[' *> get <* char ']')) +++ (Nothing <$ string "   ")
-
-parseCmd :: ReadP (Int, Int, Int)
-parseCmd =
-  (,,) <$> (string "move " *> getInt)
-    <*> (string " from " *> getInt)
-    <*> (string " to " *> getInt)
-  where
-    getInt :: ReadP Int
-    getInt = read <$> many1 (satisfy isDigit)

day6.hs

@@ -1,16 +0,0 @@
-import Data.List (nub)
-
-main :: IO ()
-main = do
-  input <- readFile "day6.in"
-  putStr "Q1: "
-  print $ parse 4 input
-  putStr "Q2: "
-  print $ parse 14 input
-
-group :: Int -> [Char] -> [[Char]]
-group _ [] = []
-group n xs = take n xs : group n (tail xs)
-
-parse :: Int -> String -> Int
-parse n = (+ n) . length . takeWhile ((< n) . length) . map nub . group n

day8.hs

@@ -1,52 +0,0 @@
-import Data.Char (digitToInt)
-import Data.List (transpose, zip4, zipWith4)
-
--- a fun approach, not necessarily the fastest (or cleanest (or smartest))
-
-main :: IO ()
-main = do
-  input <- map (map digitToInt) . lines <$> readFile "day8.in"
-  let (e, w, n, s) = trees input
-  let obscured = zipWith4 zip4 e w n s
-  putStr "Q1: "
-  print $
-    length $
-      filter
-        (not . (\((w, _), (x, _), (y, _), (z, _)) -> w && y && x && z))
-        $ concat obscured
-  putStr "Q2: "
-  print $
-    maximum $
-      map (\((_, w), (_, x), (_, y), (_, z)) -> w * x * y * z) $
-        concat obscured
-
-type Forest = [[(Bool, Int)]]
-
-trees :: [[Int]] -> (Forest, Forest, Forest, Forest)
-trees input =
-  ( trees' input,
-    map reverse $ trees' $ map reverse input,
-    transpose $ trees' $ transpose input,
-    reverse $ transpose $ trees' $ transpose $ reverse input
-  ) -- (east, west, north, south) traversals
-  where
-    trees' :: [[Int]] -> Forest
-    trees' =
-      foldr
-        ( \x xs ->
-            let (_, dist) =
-                  foldr
-                    ( \(cur, y) ((old, m), ys) ->
-                        ( if y > m then (cur, y) else (old, m),
-                          ( y <= m,
-                            let s = length $ takeWhile (< y) $ reverse $ take cur x
-                             in if s == cur then s else s + 1
-                          ) :
-                          ys
-                        )
-                    )
-                    ((-1, -1), [])
-                    (zip [0 ..] x)
-             in dist : xs
-        )
-        []