Advent of Code 2021, learning Haskell

p01a.hs

countIncrease :: [Int] -> Int
countIncrease xs = length $ filter (uncurry (<)) $ zip xs (tail xs)

main :: IO ()
main = print . countIncrease . map read . lines =<< getContents

p01b.hs

countIncrease :: [Int] -> Int
countIncrease xs = length $ filter (uncurry (<)) $ zip xs (tail xs)

threeMeasurement :: [Int] -> [Int]
threeMeasurement xs = zipWith3 (\a b c -> a + b + c) xs (tail xs) (drop 2 xs)

main :: IO ()
main = print . countIncrease . threeMeasurement . map read . lines =<< getContents

p02a.hs

import Data.Bifunctor

parseLine :: String -> (Int, Int) -> (Int, Int)
parseLine s = case dir of
    "forward" -> first  (+delta)
    "down"    -> second (+delta)
    "up"      -> second (+ (-delta))
    _         -> error "!"
  where
    [dir, delta'] = words s
    delta = read delta'

main :: IO ()
main = print . uncurry (*) . ($ (0, 0)) . foldr (.) id . map parseLine . lines =<< getContents

p02b.hs

import Data.Bifunctor

parseLine :: String -> ((Int, Int), Int) -> ((Int, Int), Int)
parseLine s = case dir of
    "forward" -> \((x, y), a) -> ((x + delta, y + a * delta), a)
    "down"    -> second (+delta)
    "up"      -> second (+ (-delta))
    _         -> error "!"
  where
    [dir, delta'] = words s
    delta = read delta'

main :: IO ()
main = print . uncurry (*) . fst . ($ ((0, 0), 0)) . foldr (flip (.)) id . map parseLine . lines =<< getContents

p03a.hs

import Data.Char
import Data.List
import Data.Bits

solve :: [String] -> Int
solve xs = sum gam * sum eps where
    len = length $ head xs
    xs' = map parseBin xs
    go p = if length o > length z then (p, 0) else (0, p) where
        (o, z) = partition ((==p) . (.&.p)) xs'
    (gam, eps) = unzip $ map go $ take len $ iterate (*2) 1

parseBin :: String -> Int
parseBin = foldl' (\acc c -> acc * 2 + digitToInt c) 0

main :: IO ()
main = print . solve . lines =<< getContents

p03b.hs

import Data.Char
import Data.List

solve :: [String] -> Int
solve xs = parseBin (go oxytakeo) * parseBin (go co2takeo) where
    go f = go' 0 xs where
        go' _ []  = error "!"
        go' _ [x] = x
        go' i xs  = go' (i + 1) xs' where
            (o, z) = partition ((=='1') . (!!i)) xs
            xs' = if length o `f` length z then o else z
    oxytakeo = (>=)
    co2takeo = (<)

parseBin :: String -> Int
parseBin = foldl' (\acc c -> acc * 2 + digitToInt c) 0

main :: IO ()
main = print . solve . lines =<< getContents

p04.hs

import Control.Monad
import Data.Foldable
import Data.List

type Board = [[Int]]

solve1 :: ([Int], [Board]) -> Maybe Int
solve1 (xs, boards) = asum $ map getFirst $ inits xs where
    getFirst xs' = asum $ map getScore boards where
        test = any (all (`elem` xs'))
        getScore board = score <$ guard (test board || test (transpose board)) where
            score = last xs' * sum (filter (`notElem` xs') $ concat board)

solve2 :: ([Int], [Board]) -> Maybe Int
solve2 (xs, boards) = asum $ map getFirst $ reverse $ inits xs where
    getFirst xs' = asum $ map getScore boards where
        testCur = any (all (`elem` xs'))
        testLast = not . any (all (`elem` init xs'))
        getScore board = score <$ guard ok where
            ok = (testCur board || testCur (transpose board)) && testLast board && testLast (transpose board)
            score = last xs' * sum (filter (`notElem` xs') $ concat board)

parse :: String -> ([Int], [Board])
parse s = (xs, boards) where
    ls = lines s
    xs = read $ "[" ++ head ls ++ "]"
    boards = map tail $ chunksOf 6 $ map (map read . words) $ tail ls

chunksOf :: Int -> [a] -> [[a]]
chunksOf n = go where
    go [] = []
    go xs = xs' : go xs'' where (xs', xs'') = splitAt n xs

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p05a.hs

import qualified Data.Map as M

type Point = (Int, Int)
type Line = (Point, Point)

axisAligned :: Line -> Bool
axisAligned ((x1, y1), (x2, y2)) = x1 == x2 || y1 == y2

genPoints :: Line -> [Point]
genPoints ((x1, y1), (x2, y2)) =
    [(x, y) | x <- [min x1 x2 .. max x1 x2], y <- [min y1 y2 .. max y1 y2]]

solve :: [Line] -> Int
solve ls = M.size $ M.filter (>1) $ M.fromListWith (+) [(p, 1) | p <- concatMap genPoints ls'] where
    ls' = filter axisAligned ls

parse :: String -> [Line]
parse = map parseLine . lines where
    parseLine l = (p1, p2) where
        [p1s, "->", p2s] = words l
        [p1, p2] = map parsePoint [p1s, p2s]
    parsePoint ps = read $ "(" ++ ps ++ ")"

main :: IO ()
main = print . solve . parse =<< getContents

p05b.hs

import qualified Data.Map as M

type Vec2 = (Int, Int)
data Line = Line { start :: Vec2, dir :: Vec2, len :: Int }

add, sub :: Vec2 -> Vec2 -> Vec2
add (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
sub (x1, y1) (x2, y2) = (x1 - x2, y1 - y2)

mkLine :: Vec2 -> Vec2 -> Line
mkLine p1 p2
    | ok        = Line p1 (signum dx, signum dy) n
    | otherwise = error "bad line"
  where
    (dx, dy) = p2 `sub` p1
    ok = dx == 0 || dy == 0 || abs dx == abs dy
    n = abs dx `max` abs dy

genPoints :: Line -> [Vec2]
genPoints (Line p d n) = take (n + 1) $ iterate (add d) p

solve :: [Line] -> Int
solve ls = M.size $ M.filter (>1) $ M.fromListWith (+) [(p, 1) | p <- concatMap genPoints ls]

parse :: String -> [Line]
parse = map parseLine . lines where
    parseLine l = mkLine p1 p2 where
        [p1s, "->", p2s] = words l
        [p1, p2] = map parsePoint [p1s, p2s]
    parsePoint ps = read $ "(" ++ ps ++ ")"

main :: IO ()
main = print . solve . parse =<< getContents

p06.hs

{-# LANGUAGE TupleSections #-}
import Control.Arrow
import Data.List
import Data.Function

solve1 :: [Int] -> Int
solve1 = length . (!!80) . iterate (concatMap next) where
    next 0 = [6, 8]
    next x = [x - 1]

solve2 :: [Int] -> Int
solve2 = sum . map snd . (!!256) . iterate (merge . concatMap next) . map (,1) where
    next (0, c) = [(6, c), (8, c)]
    next (x, c) = [(x - 1, c)]
    merge = map (fst . head &&& sum . map snd) . groupBy ((==) `on` fst) . sort

parse :: String -> [Int]
parse s = read $ "[" ++ s ++ "]"

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p07.hs

import Data.List

solve1 :: [Int] -> Int
solve1 xs = sum $ map (abs . (mid-)) xs where
    n = length xs
    mid = sort xs !! (n `div` 2)

solve2 :: [Int] -> Int
solve2 xs = minimum $ map totalCost [minimum xs .. maximum xs] where
    totalCost x = sum $ map (cost . abs . (x-)) xs
    cost x = x * (x + 1) `div` 2

parse :: String -> [Int]
parse s = read $ "[" ++ s ++ "]"

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p08.hs

import Data.Char
import Data.List
import Data.Maybe

segs :: [[Int]]
segs = map (map digitToInt)
    [ "012456"
    , "25"
    , "02346"
    , "02356"
    , "1235"
    , "01356"
    , "013456"
    , "025"
    , "0123456"
    , "012356"
    ]

allPerms :: [Int -> Int]
allPerms = map (!!) (permutations [0..7])

decode :: [String] -> (Int -> Int) -> Maybe [Int]
decode digits perm = mapM ((`elemIndex` segs) . sort . map (perm . subtract (ord 'a') . ord)) digits

solve1 :: [([String], [String])] -> Int
solve1 = sum . map solve1 where
    solve1 (_, digits) = length $ filter ((`elem` uniqueLengths) . length) digits
    uniqueLengths = [2, 4, 3, 7]

solve2 :: [([String], [String])] -> Int
solve2 = sum . map solve1 where
    solve1 (patterns, digits) =
        read . concatMap show .
        fromJust . decode digits .
        head . filter (maybe False ((==[0..9]) . sort) . decode patterns) $ allPerms

parse :: String -> [([String], [String])]
parse = map parseLine . lines where
    parseLine s = let (s', s'') = break (=='|') s in (words s', words $ tail s'')

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p09.hs

import Data.Char
import Data.List
import Data.Graph
import Data.Maybe
import qualified Data.Map as M

type Point = (Int, Int)

neighbors :: Point -> [Point]
neighbors (x, y) = [(x, y - 1), (x, y + 1), (x - 1, y), (x + 1, y)]

solve1 :: M.Map Point Int -> Int
solve1 g = sum $ map ((+1) . snd) $ filter lowPoint $ M.assocs g where
    lowPoint (xy, d) = all (>d) $ mapMaybe (g M.!?) $ neighbors xy

solve2 :: M.Map Point Int -> Int
solve2 g = product $ take 3 $ sortBy (flip compare) $ map length $ dff g' where
    (g', _, _) = graphFromEdges $ map getNode $ M.assocs g
    getNode (xy, d) = ((), xy, nbs) where
        nbs | d == 9    = []
            | otherwise = filter (maybe False (/=9) . (g M.!?)) $ neighbors xy

parse :: String -> M.Map Point Int
parse s = M.fromList $ zip ((,) <$> [1..n] <*> [1..m]) (concat xss) where
    xss = map (map digitToInt) $ lines s
    n = length xss
    m = length $ head xss

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p10.hs

{-# LANGUAGE LambdaCase #-}
import Data.List
import Data.Maybe

close :: Char -> Char
close = \case
    '(' -> ')'
    '[' -> ']'
    '{' -> '}'
    '<' -> '>'
    _   -> error "!"

solve1 :: [String] -> Int
solve1 = sum . map (go []) where
    go _ [] = 0
    go ys (x:xs)
        | x `elem` "([{<"             = go (x:ys) xs
        | (y:ys') <- ys, x == close y = go ys' xs
        | otherwise                   = score x
    score = \case
        ')' -> 3
        ']' -> 57
        '}' -> 1197
        '>' -> 25137
        _   -> error "!"

solve2 :: [String] -> Int
solve2 ls = sort scores !! (length scores `div` 2) where
    scores = mapMaybe (go []) ls
    go ys [] = Just $ foldl' (\acc x -> acc * 5 + score (close x)) 0 ys
    go ys (x:xs)
        | x `elem` "([{<"             = go (x:ys) xs
        | (y:ys') <- ys, x == close y = go ys' xs
        | otherwise                   = Nothing
    score = \case
        ')' -> 1
        ']' -> 2
        '}' -> 3
        '>' -> 4
        _   -> error "!"

main :: IO ()
main = do
    p <- lines <$> getContents
    print $ solve1 p
    print $ solve2 p

p11.hs

import Control.Monad
import Control.Monad.Writer
import Data.Char
import Data.List
import qualified Data.Map as M

type Point = (Int, Int)
type Grid = M.Map Point Int

neighbors :: Point -> [Point]
neighbors (x, y) = [(x + dx, y + dy) | dx <- [-1..1], dy <- [-1..1], dx /= 0 || dy /= 0]

solve1 :: Grid -> Int
solve1 = getSum . execWriter . foldr (>=>) pure (replicate 100 $ flash . fmap (+1)) where
    flash :: Grid -> Writer (Sum Int) Grid
    flash g
        | M.null g9 = pure g
        | otherwise = do
            tell $ Sum (M.size g9)
            M.union (fmap (const 0) g9) <$> flash g''
      where
        (g9, g') = M.partition (>9) g
        g'' = foldr (M.adjust (+1)) g' $ concatMap neighbors $ M.keys g9

solve2 :: Grid -> Int
solve2 = length . unfoldr go where
    go g = ((), flash $ fmap (+1) g) <$ guard (any (/=0) $ M.elems g)
    flash g
        | M.null g9 = g
        | otherwise = M.union (fmap (const 0) g9) $ flash g''
      where
        (g9, g') = M.partition (>9) g
        g'' = foldr (M.adjust (+1)) g' $ concatMap neighbors $ M.keys g9

parse :: String -> Grid
parse = M.fromList . zip ((,) <$> [1..10] <*> [1..10]) . map digitToInt . filter isDigit

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p12.hs

import Control.Monad.Writer
import Data.Char
import qualified Data.Map as M

type Node = String
type Graph = M.Map Node [Node]

small :: Node -> Bool
small = all isLower

solve1 :: Graph -> Int
solve1 g = getSum $ execWriter $ dfs [] "start" where
    dfs :: [Node] -> Node -> Writer (Sum Int) ()
    dfs _ "end" = tell $ Sum 1
    dfs seen u | u `elem` seen = pure ()
    dfs seen u = mapM_ (dfs seen') $ g M.! u where
        seen' = if small u then u:seen else seen

solve2 :: Graph -> Int
solve2 g = getSum $ execWriter $ dfs [] False "start" where
    dfs :: [Node] -> Bool -> Node -> Writer (Sum Int) ()
    dfs _ _ "end" = tell $ Sum 1
    dfs seen twice u | u `elem` seen && (u == "start" || twice) = pure ()
    dfs seen twice u = mapM_ (dfs seen' twice') $ g M.! u where
        seen' = if small u then u:seen else seen
        twice' = twice || u `elem` seen

parse :: String -> Graph
parse = M.fromListWith (++) . concatMap parseEdge . lines where
    parseEdge s = [(u, [v]), (v, [u])] where
        [u, v] = words $ map (\c -> if c == '-' then ' ' else c) s

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p13.hs

import Data.List

type Point = (Int, Int)
type Fold = Point -> Point

solve1 :: ([Point], [Fold]) -> Int
solve1 (ps, ~(f:_)) = length $ group $ sort $ map f ps

solve2 :: ([Point], [Fold]) -> String
solve2 (ps, fs) = code where
    ps' = foldl' (flip (.)) id fs <$> ps
    mx = maximum $ map fst ps'
    my = maximum $ map snd ps'
    code = unlines [[if (x, y) `elem` ps' then '█' else ' ' | x <- [0..mx]] | y <- [0..my]]

parse :: String -> ([Point], [Fold])
parse s = (map parsePoint ps, map parseFold fs) where
    (ps, _:fs) = break null $ lines s
    parsePoint s = read $ "(" ++ s ++ ")"
    parseFold s = case axis of
        'x' -> foldx
        'y' -> foldy
        _   -> error "!"
      where
        ["fold", "along", axis:'=':num] = words s
        num' = read num
        foldx xy@(x, y) = if x > num' then (2 * num' - x, y) else xy
        foldy xy@(x, y) = if y > num' then (x, 2 * num' - y) else xy

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    putStrLn $ solve2 p

p14.hs

{-# LANGUAGE TupleSections #-}
import Data.List
import qualified Data.Map as M

type Replace = (Char, Char) -> Maybe Char

solve1 :: (String, Replace) -> Int
solve1 (template, replace) = maximum freqs - minimum freqs where
    step (a:b:xs) = case replace (a, b) of
        Nothing -> a : step (b:xs)
        Just c  -> a : c : step (b:xs)
    step xs = xs
    t = iterate step template !! 10
    freqs = map length $ group $ sort t

solve2 :: (String, Replace) -> Int
solve2 (template, replace) = maximum freqs - minimum freqs where
    nxt cur@((a, b), cnt) = case replace (a, b) of
        Nothing -> [cur]
        Just c  -> [((a, c), cnt), ((c, b), cnt)]
    t = "*" ++ template ++ "*"
    freqs =
        map ((`div` 2) . snd) $
        filter ((/='*') . fst) $
        combine $ concatMap split $
        iterate (combine . concatMap nxt) (map (,1) $ zip t (tail t)) !! 40

    combine :: Ord a => [(a, Int)] -> [(a, Int)]
    combine = M.assocs . M.fromListWith (+)
    split ((a, b), cnt) = [(a, cnt), (b, cnt)]

parse :: String -> (String, Replace)
parse s = (p, (`lookup` rules)) where
    p:"":s' = lines s
    rules = map parseRule s'
    parseRule s = ((a, b), c) where
        [[a, b], "->", [c]] = words s

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p15.hs

import Data.Bifunctor
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S

type Point = (Int, Int)
type Grid = M.Map Point Int

neighbors :: Point -> [Point]
neighbors (x, y) = [(x, y - 1), (x, y + 1), (x - 1, y), (x + 1, y)]

solve1 :: (Int, Int, Grid) -> Int
solve1 (n, m, g) = final M.! (n, m) where
    dijkstra (dist, pq) = case S.minView pq of
        Nothing -> dist
        Just ((d, xy), pq') -> dijkstra $ foldl' upd (dist, pq') $ neighbors xy where
            upd dp@(dist', pq'') xy'
                | maybe True (<=new) maybeCur = dp
                | otherwise = (M.insert xy' new dist', S.insert (new, xy') $ S.delete (cur, xy') pq'')
              where
                maybeCur = dist' M.!? xy'
                cur = fromJust maybeCur
                new = d + g M.! xy'
    final = dijkstra (M.insert (1, 1) 0 $ M.map (const $ maxBound `div` 2) g, S.singleton (0, (1, 1)))

solve2 :: (Int, Int, Grid) -> Int
solve2 (n, m, g) = solve1 (5 * n, 5 * m, scaleUp g) where
    scaleUp = M.unions . concatMap (take 5 . iterate upy) . take 5 . iterate upx where
        upc = (+1) . (`mod` 9)
        upx = M.mapKeys (first  (+n)) . fmap upc
        upy = M.mapKeys (second (+m)) . fmap upc

parse :: String -> (Int, Int, Grid)
parse s = (n, m, M.fromList $ zip ((,) <$> [1..n] <*> [1..m]) (concat xss)) where
    xss = map (map digitToInt) $ lines s
    n = length xss
    m = length $ head xss

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p16.hs

import Data.Char
import Data.List
import Text.ParserCombinators.ReadP
import Text.Printf

data Packet = Literal  { pVersion :: Int, pValue :: Int }
            | Operator { pVersion :: Int, pType :: Int, pPackets :: [Packet] }

solve1 :: Packet -> Int
solve1 = go where
    go (Literal  ver _)    = ver
    go (Operator ver _ ps) = ver + sum (map go ps)

solve2 :: Packet -> Int
solve2 = go where
    go (Literal  _ val)    = val
    go (Operator _ typ ps) = ops !! typ $ map go ps
    ops = [sum, product, minimum, maximum, error "literal"] ++
          map (\f [a, b] -> fromEnum $ f a b) [(>), (<), (==)]

parse :: String -> Packet
parse = fst . head . readP_to_S packet . concatMap (printf "%04b" . digitToInt) where
    packet = literal +++ operator
    literal = Literal <$> readInt 3 <* string "100" <*> value where
        value = merge <$> many (char '1' *> readString 4) <* char '0' <*> readString 4
        merge init_ last_ = parseBin $ concat init_ ++ last_
    operator = Operator <$> readInt 3 <*> readInt 3 <*> packets where
        packets = (char '0' *> byLength) +++ (char '1' *> byCount)
        byLength = fst . last . readP_to_S (many packet) <$> (readString =<< readInt 15)
        byCount = flip count packet =<< readInt 11

    readString n = count n $ char '0' +++ char '1'
    readInt = fmap parseBin . readString

parseBin :: String -> Int
parseBin = foldl' (\acc c -> acc * 2 + digitToInt c) 0

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p17.hs

import Control.Monad
import Data.Char

-- 0 < x1 <= x2; y1 <= y2 < 0

solve1 :: (Int, Int, Int, Int) -> Int
solve1 (_, _, y1, _) = y1 * (y1 + 1) `div` 2 -- assume that this will work for some vx 🙃

solve2 :: (Int, Int, Int, Int) -> Int
solve2 (x1, x2, y1, y2) = length $ do
    vx <- [1..x2]
    vy <- [y1.. -y1]
    guard $ not . null $
        dropWhile tooClose $ takeWhile (not . tooFar) $ zip (positions ax vx) (positions ay vy)
  where
    positions a v = scanl (+) 0 $ iterate a v
    ax = max 0 . subtract 1
    ay = subtract 1
    tooFar   (x, y) = x > x2 || y < y1
    tooClose (x, y) = x < x1 || y > y2

parse :: String -> (Int, Int, Int, Int)
parse s = (x1, x2, y1, y2) where
    [x1, x2, y1, y2] = map read $ words $ map (\c -> if c == '-' || isDigit c then c else ' ') s

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p18.hs

import Control.Applicative
import Control.Monad
import Data.Char
import Data.List
import Text.ParserCombinators.ReadP

data SnailfishNum = S Int | P SnailfishNum SnailfishNum

snailfishNum :: ReadP SnailfishNum
snailfishNum = single +++ pair where
    single = S . read <$> munch1 isDigit
    pair = between (char '[') (char ']') $ P <$> snailfishNum <* char ',' <*> snailfishNum

explode :: SnailfishNum -> Maybe SnailfishNum
explode = fmap (\(n, _, _) -> n) . go (0 :: Int) where
    go _ (S _)           = Nothing
    go 4 (P (S a) (S b)) = Just (S 0, Just a, Just b)
    go 4 _               = error "not expected"
    go d (P a b) = explodea <|> explodeb where
        explodea = (\(a', l, r) -> (P a' (maybe b (addL b) r), l, Nothing)) <$> go (d + 1) a
        explodeb = (\(b', l, r) -> (P (maybe a (addR a) l) b', Nothing, r)) <$> go (d + 1) b
    addL (S x)   y = S (x + y)
    addL (P a b) y = P (addL a y) b
    addR (S x)   y = S (x + y)
    addR (P a b) y = P a (addR b y)

split :: SnailfishNum -> Maybe SnailfishNum
split (S x)   = P (S x') (S (x - x')) <$ guard (x >= 10) where x' = x `div` 2
split (P a b) = (flip P b <$> split a) <|> (P a <$> split b)

add :: SnailfishNum -> SnailfishNum -> SnailfishNum
add a b = reduce $ P a b where
    reduce n = maybe n reduce $ explode n <|> split n

magnitude :: SnailfishNum -> Int
magnitude (S x)   = x
magnitude (P a b) = 3 * magnitude a + 2 * magnitude b

solve1 :: [SnailfishNum] -> Int
solve1 = magnitude . foldl1 add

solve2 :: [SnailfishNum] -> Int
solve2 = maximum . map (magnitude . uncurry add) . ordPairs

ordPairs :: [a] -> [(a, a)]
ordPairs xs = [(x, x') | (ls, x:rs) <- zip (inits xs) (tails xs), x' <- ls ++ rs]

parse :: String -> [SnailfishNum]
parse = map (fst . head . readP_to_S snailfishNum) . lines

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p19.hs

import Control.Monad
import Data.List
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Text as T

type Vec3 = (Int, Int, Int)

add :: Vec3 -> Vec3 -> Vec3
add (x, y, z) (x', y', z') = (x + x', y + y', z + z')

neg :: Vec3 -> Vec3
neg (x, y, z) = (-x, -y, -z)

sub :: Vec3 -> Vec3 -> Vec3
sub v v' = v `add` neg v'

magnitude :: Vec3 -> Int
magnitude (x, y, z) = abs x + abs y + abs z

orientations :: Vec3 -> [Vec3]
orientations = concatMap setyz . setx where
    setx  (x, y, z) = [(x, y, z), (-x, z, y), (y, z, x), (-y, x, z), (z, x, y), (-z, y, x)]
    setyz (x, y, z) = [(x, y, z), (x, -z, y), (x, -y, -z), (x, z, -y)]

reorientMany :: [Vec3] -> [[Vec3]]
reorientMany = transpose . map orientations

----------------------------------------

type Scanner = S.Set Vec3
type ScannerPos = Vec3
type Beacons = S.Set Vec3

tryMerge :: Scanner -> Scanner -> Maybe (ScannerPos, Scanner)
tryMerge s s' = listToMaybe $ do
    first      <- S.toList s
    reoriented <- reorientMany $ S.toList s'
    first'     <- reoriented
    let diff    = first `sub` first'
        shifted = S.fromList $ map (add diff) reoriented
    guard $ S.size (S.intersection s shifted) >= 12
    pure (neg diff, S.union s shifted)

solve :: [Scanner] -> (Beacons, [ScannerPos])
solve [] = error "no scanners"
solve (s:ss) = go s [(0, 0, 0)] ss where
    go s ps [] = (s, ps)
    go s ps ss = go s' ps' ss' where
        (s', ps', ss') = foldl' f (s, ps, []) ss
        f (s, ps, ss) s' = case tryMerge s s' of
            Nothing       -> (s,   ps,   s':ss)
            Just (p, s'') -> (s'', p:ps, ss)

parse :: String -> [Scanner]
parse = map parseScanner . splitScanners where
    splitScanners = map T.unpack . T.splitOn (T.pack "\n\n") . T.pack
    parseScanner = S.fromList . map (read . (\p -> "(" ++ p ++ ")")) . tail . lines

pairs :: [a] -> [(a, a)]
pairs xs = [(x, x') | (x:xs') <- tails xs, x' <- xs']

main :: IO ()
main = do
    p <- parse <$> getContents
    let (beacons, scanners) = solve p
    print $ S.size beacons
    print $ maximum $ map (magnitude . uncurry sub) $ pairs scanners

p20.hs

import Data.Ix
import Data.List
import qualified Data.Set as S

type Point = (Int, Int)
data Image = Image { bounds_ :: (Point, Point), on_ :: S.Set Point, onOutside_ :: Bool }

neighborhood :: Point -> [Point]
neighborhood (x, y) = [(x + dx, y + dy) | dx <- [-1..1], dy <- [-1..1]]

expandBy1 :: (Point, Point) -> (Point, Point)
expandBy1 ((x1, y1), (x2, y2)) = ((x1-1, y1-1), (x2+1, y2+1))

enhance :: (Int -> Bool) -> Image -> Image
enhance setOn (Image bnds on onOutside) = Image bnds' on' onOutside' where
    bnds' = expandBy1 bnds
    on' = S.fromList $ filter setPosOn $ range bnds'
    setPosOn = setOn . toInt . map posOn . neighborhood
    posOn p = S.member p on || not (inRange bnds p) && onOutside
    toInt = foldl' (\acc x -> acc * 2 + fromEnum x) 0
    onOutside' = onOutside && setOn 0x1ff || not onOutside && setOn 0

countOn :: Image -> Int
countOn (Image _ _  True) = error "infinite"
countOn (Image _ on _)    = S.size on

solve :: (Int -> Bool, Image) -> Int -> Int
solve (setOn, im) n = countOn $ foldl' (flip ($)) im $ replicate n $ enhance setOn

parse :: String -> (Int -> Bool, Image)
parse s = (flip S.member setOn, Image ((1, 1), (n, m)) on False) where
    (h:"":s') = lines s
    setOn = S.fromList [i | (i, c) <- zip [0 :: Int ..] h, c == '#']
    n = length s'
    m = length $ head s'
    on = S.fromList [(x, y) | (x, l) <- zip [1..] s', (y, c) <- zip [1..] l, c == '#']

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve p 2
    print $ solve p 50

p21.hs

{-# LANGUAGE BangPatterns, TupleSections #-}
import Control.Monad
import Data.List
import qualified Data.Map as M

add :: (Int, Int) -> (Int, Int) -> (Int, Int)
add (!a1, !a2) (!b1, !b2) = (a1 + b1, a2 + b2)

mul :: Int -> (Int, Int) -> (Int, Int)
mul x (!a1, !a2) = (a1 * x, a2 * x)

solve1 :: (Int, Int) -> Int
solve1 (a, b) = go (a, 0) (b, 0) 1 0 where
    go (pos1, score1) (pos2, score2) dice diceCnt
        | score2 >= 1000 = score1 * diceCnt
        | otherwise      = go (pos2, score2) (pos1', score1') dice' (diceCnt + 3)
      where
        roll    = 3 * dice + 3
        pos1'   = (pos1 + roll - 1) `mod` 10 + 1
        score1' = score1 + pos1'
        dice'   = (dice + 3 - 1) `mod` 100 + 1

solve2 :: (Int, Int) -> Int
solve2 (a, b) = uncurry max $ go (a, 0, (1, 0)) (b, 0, (0, 1)) where
    go (pos1, score1, pt1) (pos2, score2, pt2)
        | score2 >= 21 = pt2
        | otherwise    = foldl' add (0, 0) $ map f counts
      where
        f (roll, rollCnt) = mul rollCnt $ go (pos2, score2, pt2) (pos1', score1', pt1) where
            pos1'   = (pos1 + roll - 1) `mod` 10 + 1
            score1' = score1 + pos1'
    counts = M.assocs $ M.fromListWith (+) $ map ((,1) . sum) $ replicateM 3 [1, 2, 3]

parse :: String -> (Int, Int)
parse s = (read $ last $ words l1, read $ last $ words l2) where [l1, l2] = lines s

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p22.hs

import Data.Char
import Data.List
import Data.Maybe

type Range = (Int, Int)
type RectN = [Range] -- n-element list for n dimensions
data Instruction = Inst { on :: Bool, bnds :: RectN }

size :: RectN -> Int
size = product . map (\(l, r) -> r - l + 1)

split :: Range -> Range -> (Maybe Range, [Range])
split (a1, a2) (b1, b2)
    | c1 > c2   = (Nothing,       [(b1, b2)])
    | otherwise = (Just (c1, c2), [(c1, c2)] ++ [(b1, c1 - 1) | b1 < c1] ++ [(c2 + 1, b2) | c2 < b2])
  where
    c1 = max a1 b1
    c2 = min a2 b2

splitN :: RectN -> RectN -> (Maybe RectN, [RectN])
splitN a b = (sequence is, sequence ps) where
    (is, ps) = unzip $ zipWith split a b

cutN :: RectN -> RectN -> [RectN]
cutN a b = if isJust isect then tail pieces else [b] where
    (isect, pieces) = splitN a b

solve :: [Instruction] -> [RectN]
solve = foldl' apply [] where
    apply ons inst = [bnds inst | on inst] ++ concatMap (cutN $ bnds inst) ons

parse :: String -> [Instruction]
parse = map parseLine . lines where
    parseLine s = Inst o [(x1, x2), (y1, y2), (z1, z2)] where
        o = head (words s) == "on"
        [x1, x2, y1, y2, z1, z2] = map read $ words $ map (\c -> if c == '-' || isDigit c then c else ' ') s

main :: IO ()
main = do
    p <- parse <$> getContents
    let boxes = solve p
        chopTo50 = fst . splitN (replicate 3 (-50, 50))
    print $ sum $ map size $ mapMaybe chopTo50 boxes
    print $ sum $ map size boxes

p23.hs

import Control.Monad
import Data.Bifunctor
import Data.Char
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S

data Amphipod = A | B | C | D deriving (Eq, Ord, Read)
data Burrow   = B1 | B2 | B3 | B4 deriving (Enum, Eq, Ord)
data Space    = S1 | S2 | S4 | S6 | S8 | S10 | S11 deriving (Enum, Eq, Ord)

cost :: Amphipod -> Int
cost A = 1
cost B = 10
cost C = 100
cost D = 1000

goal :: Amphipod -> Burrow
goal A = B1
goal B = B2
goal C = B3
goal D = B4

type Dist = Int

getOut :: Burrow -> ([(Space, Dist)], [(Space, Dist)])
getOut = first reverse . go where
    go B1 = splitAt 2 $ zip hallway [3, 2, 2, 4, 6, 8, 9]
    go B2 = splitAt 3 $ zip hallway [5, 4, 2, 2, 4, 6, 7]
    go B3 = splitAt 4 $ zip hallway [7, 6, 4, 2, 2, 4, 5]
    go B4 = splitAt 5 $ zip hallway [9, 8, 6, 4, 2, 2, 3]
    hallway = [S1 .. S11]

getOutOk :: [Space] -> Burrow -> [(Space, Dist)]
getOutOk occ b = p l ++ p r where
    (l, r) = getOut b
    p = takeWhile ((`notElem` occ) . fst)

data State = State
           { burrows_ :: M.Map Burrow [Amphipod]
           , spaces_  :: M.Map Space Amphipod
           } deriving (Eq, Ord)

next :: State -> [(Int, State)]
next (State burrows spaces) = burrowToSpace ++ spaceToBurrow where
    total = (length spaces + sum (fmap length burrows)) `div` 4
    occ = M.keys spaces
    burrowToSpace = do
        (b, as@(a:as')) <- M.assocs burrows
        (s, d) <- getOutOk occ b
        let d'  = d + total - length as
            st' = State (M.insert b as' burrows) (M.insert s a spaces)
        pure (cost a * d', st')
    spaceToBurrow = do
        (s, a) <- M.assocs spaces
        let b  = goal a
            as = burrows M.! b
        guard $ all (==a) as
        (s', d) <- getOutOk (delete s occ) b
        guard $ s == s'
        let d'  = d + total - length as - 1
            st' = State (M.insert b (a:as) burrows) (M.delete s spaces)
        pure (cost a * d', st')

shortestPath :: (Ord v) => v -> (v -> [(Int, v)]) -> v -> Int
shortestPath src nxt dst = dijkstra (M.singleton src 0, S.singleton (0, src)) where
    dijkstra (dist, pq) = case S.minView pq of
        Nothing -> error "dst not found"
        Just ((d, u), _) | u == dst -> d
        Just ((d, u), pq') -> dijkstra $ foldl' upd (dist, pq') $ nxt u where
            upd dp@(dist, pq) (w, v) = case dist M.!? v of
                Nothing            -> (dist', pq')
                Just dv | dv' < dv -> (dist', S.delete (dv, v) pq')
                _                  -> dp
              where
                dv'   = d + w
                dist' = M.insert v dv' dist
                pq'   = S.insert (dv', v) pq

solve1 :: M.Map Burrow [Amphipod] -> Int
solve1 b = shortestPath st next st' where
    st  = State b M.empty
    st' = State (M.fromList $ map gen [A, B, C, D]) M.empty where gen a = (goal a, [a, a])

solve2 :: M.Map Burrow [Amphipod] -> Int
solve2 b = shortestPath st next st' where
    b' = M.fromList
        [ (b, [a0,a1,a2,a3])
        | ((b, [a0,a3]), [a1,a2]) <- zip (M.assocs b) [[D,D], [C,B], [B,A], [A,C]]
        ]
    st  = State b' M.empty
    st' = State (M.fromList $ map gen [A, B, C, D]) M.empty where gen a = (goal a, [a, a, a, a])

parse :: String -> M.Map Burrow [Amphipod]
parse s = M.fromList $ zip [B1 .. B4] $ zipWith (\a b -> [a, b]) row1 row2 where
    (row1, row2) = splitAt 4 $ map (read . (:[])) (filter isAlpha s)

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve1 p
    print $ solve2 p

p24.hs

import Control.Monad
import Data.List
import qualified Data.Map.Strict as M

data ALUState = ALUState
              { aw :: {-# UNPACK #-} !Int
              , ax :: {-# UNPACK #-} !Int
              , ay :: {-# UNPACK #-} !Int
              , az :: {-# UNPACK #-} !Int
              } deriving (Eq, Ord, Show)
type Step = Int -> ALUState -> ALUState

variables :: String
variables = "wxyz"

readA :: Char -> ALUState -> Int
readA 'w' = aw
readA 'x' = ax
readA 'y' = ay
readA 'z' = az
readA _   = error "bad variable"

writeA :: Int -> Char -> ALUState -> ALUState
writeA v 'w' alu = alu { aw = v }
writeA v 'x' alu = alu { ax = v }
writeA v 'y' alu = alu { ay = v }
writeA v 'z' alu = alu { az = v }
writeA _   _ _ = error "bad variable"

modifyA :: (Int -> Int) -> Char -> ALUState -> ALUState
modifyA f c alu = writeA (f (readA c alu)) c alu

solve :: [Step] -> (Int -> Int -> Int) -> Int
solve steps choose = go steps $ M.singleton start 0 where
    start = ALUState 0 0 0 0
    go [] _ = error "no steps"
    go [s] m = foldl1' choose $ do
        (st, r) <- M.assocs m
        n       <- [1..9]
        let st' = s n st
            r'  = r * 10 + n
        guard $ az st' == 0
        pure r'
    go (s:ss) m = go ss $ M.fromListWith choose $ do
        (st, r) <- M.assocs m
        n       <- [1..9]
        let st' = s n st
            r'  = r * 10 + n
        -- hack assuming a large value will not reach 0, speeds things up
        -- guard $ az st' < 1000000
        pure (st', r')

parse :: String -> [Step]
parse = go . lines where
    go [] = []
    go (l:ls) = (\v alu -> foldl' (flip ($)) (inp v alu) ops) : go ls'' where
        (ls', ls'') = break ("inp" `isPrefixOf`) ls
        inp = parseInp l
        ops = map parseOp ls'
    parseInp s = case words s of
        ["inp", a:_] -> \v -> writeA v a
        _            -> error "not inp"
    parseOp s = case words s of
        [op, a:_, b@(b':_)] -> case op of
            "add" -> makeOp (+)
            "mul" -> makeOp (*)
            "div" -> makeOp div
            "mod" -> makeOp mod
            "eql" -> makeOp $ \p q -> fromEnum $ p == q
            _     -> error "not op"
          where
            bv = read b
            makeOp f | b' `elem` variables = \m -> modifyA (`f` readA b' m) a m
                     | otherwise           = modifyA (`f` bv) a
        _ -> error "not op"

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve p max
    print $ solve p min

p25.hs

import qualified Data.Map as M

type Point    = (Int, Int)
data Cucumber = DownC | RightC deriving Eq
data Grid     = Grid Point (M.Map Point Cucumber)

down, right :: Point -> Point -> Point
down  (n, _) (x, y) = ((x + 1) `mod` n, y)
right (_, m) (x, y) = (x, (y + 1) `mod` m)

solve :: Grid -> Int
solve (Grid nm g) = 1 + length (takeWhile id $ zipWith (/=) gs (tail gs)) where
    gs = iterate (step DownC down . step RightC right) g
    step ctyp nxt g = M.fromList $ do
        (xy, c) <- M.assocs g
        let xy' = nxt nm xy
        pure $ if c == ctyp && xy' `M.notMember` g
            then (xy', c)
            else (xy,  c)

parse :: String -> Grid
parse s = Grid (n, m) g where
    ls = lines s
    n = length ls
    m = length $ head ls
    g = M.fromList
        [ ((x, y), c')
        | (x, l) <- zip [0..] ls
        , (y, c) <- zip [0..] l
        , c /= '.'
        , let c' = case c of
                '>' -> RightC
                'v' -> DownC
                _   -> error "bad cucumber"
        ]

main :: IO ()
main = do
    p <- parse <$> getContents
    print $ solve p