Advent of Code 2022

aoc-5.1.output.txt

VGBBJCRMN

aoc-5.2.output.txt

LBBVJBRMH

aoc-5.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}

import Data.Functor ((<&>))
import Data.List (foldl', transpose)
import Data.Maybe (listToMaybe)
import System.Environment (getArgs)

main :: IO ()
main = do
  part <- getArgs <&> \case
    ["2"] -> executeBlocks
    _     -> executeSequential
  putStrLn . uncurry part . parse . lines =<< getContents

type Crate = Char
type Stack = [Crate]
type State = [Stack]
type Move = (Int, Int, Int)

executeSequential :: State -> [Move] -> [Crate]
executeSequential s0 = map head . foldl' (flip execute1) s0
  where
    execute1 (n, f, t) = foldr1 (.) (replicate n $ shift1 f t)
    shift1 f t s = case listToMaybe (s !! f) of
      Just c -> modifyAt f (drop 1) $ modifyAt t (c :) s
      _ -> error $ "Empty stack " <> show f

executeBlocks :: State -> [Move] -> [Crate]
executeBlocks s0 = map head . foldl' (flip execute1) s0
  where
    execute1 (n, f, t) s = case splitAt n (s !! f) of
      (block, _rest) | length block == n -> modifyAt f (drop n) $ modifyAt t (block <>) s
      _ -> error $ "Empty stack " <> show f

parse :: [String] -> (State, [Move])
parse ls = (initialState, moves)
  where
    initialState = map stripLeft . transpose $ map extractCrates stacks
    extractCrates = map (!! 1) . chunked 4
    moves = map extractMove instructions
    extractMove (words -> [_, n, _, f, _, t]) = (read n, read f - 1, read t - 1)
    extractMove l = error $ "Badly formatted move: " <> l
    (stacks, drop 2 -> instructions) = span (beginsWith '[') ls

chunked :: Int -> [a] -> [[a]]
chunked _ [] = []
chunked n xs = chunk : chunked n rest
  where (chunk, rest) = splitAt n xs

beginsWith :: Eq a => a -> [a] -> Bool
beginsWith x = (Just x ==) . listToMaybe

stripLeft :: String -> String
stripLeft = dropWhile (== ' ')

modifyAt :: Int -> (a -> a) -> [a] -> [a]
modifyAt i f = zipWith g [0..]
  where g j x | i == j = f x
        g _ x = x

aoc-7.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}

import Data.Foldable (foldl')
import Data.Functor ((<&>))
import Data.List.NonEmpty (NonEmpty(..), (<|), singleton, uncons)
import Data.Tree (Tree(..), flatten)
import System.Environment (getArgs)
import Text.Read (readMaybe)

main :: IO ()
main = do
  part <- getArgs <&> \case
    ["2"] -> bestSize
    _     -> sumSizes
  print . part . buildTree . lines =<< getContents

type Directory = Tree Int
type Stack = NonEmpty Directory

bestSize :: Directory -> Int
bestSize d = minimum . filter (>= rootLabel d - 40_000_000) $ flatten d

sumSizes :: Directory -> Int
sumSizes = sum . filter (<= 100_000) . flatten

buildTree :: [String] -> Directory
buildTree = collapse . foldl' (flip updateTree) (singleton $ leaf 0)

updateTree :: String -> Stack -> Stack
updateTree line = case words line of
  ["$", "cd", "/"] ->
    singleton . collapse
  ["$", "cd", ".."] ->
    pop
  ["$", "cd", _name] ->
    push $ leaf 0
  [readMaybe -> Just size, _name] ->
    modifyTop $ modifyLabel (+ size)
  _ ->
    id

collapse :: Stack -> Directory
collapse = foldl1 adoptChild

adoptChild :: Directory -> Directory -> Directory
adoptChild child = modifyLabel (+ rootLabel child) . modifyForest (child :)

push :: Directory -> Stack -> Stack
push = (<|)

pop :: Stack -> Stack
pop (uncons -> (top, Just rest)) = modifyTop (adoptChild top) rest
pop _ = error "popping root"

modifyTop :: (Directory -> Directory) -> Stack -> Stack
modifyTop f (top :| rest) = f top :| rest

modifyLabel :: (a -> a) -> Tree a -> Tree a
modifyLabel f t = t { rootLabel = f $ rootLabel t }

modifyForest :: ([Tree a] -> [Tree a]) -> Tree a -> Tree a
modifyForest f t = t { subForest = f $ subForest t }

leaf :: a -> Tree a
leaf a = Node a []

Makefile

check:
	runghc -Wall -Wcompat aoc-5.hs   <aoc-5.input.txt | diff aoc-5.1.output.txt -
	runghc -Wall -Wcompat aoc-5.hs 2 <aoc-5.input.txt | diff aoc-5.2.output.txt -