Haskell

Unoptimized as hell, also brute-force approach (laptops are beasts).

{-# LANGUAGE MultiWayIf #-}

import Control.Arrow

import Control.Monad.ST (ST, runST)
import Data.Array.ST (STUArray)

import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Array.MArray as MArray

toNumber '0' = 0
toNumber '1' = 1
toNumber '2' = 2
toNumber '3' = 3
toNumber '4' = 4
toNumber '5' = 5
toNumber '6' = 6
toNumber '7' = 7
toNumber '8' = 8
toNumber '9' = 9

parse :: String -> [Int]
parse s = filter (/= '\n')
        >>> map toNumber
        >>> zip [0..]
        >>> List.concatMap (\ (index, n) -> if index `mod` 2 == 0 then replicate n (index `div` 2) else replicate n (-1))
        $ s

calculateChecksum :: [Int] -> Int
calculateChecksum = zip [0..]
        >>> filter (snd >>> (/= -1))
        >>> map (uncurry (*))
        >>> sum

moveFiles :: [Int] -> ST s Int
moveFiles bs = do
        let bLength = length bs
        marray <- MArray.newListArray (1, bLength) bs
        moveFiles' marray 1 bLength
        elems <- MArray.getElems marray
        return $ calculateChecksum elems


moveFiles' :: STUArray s Int Int -> Int -> Int -> ST s ()
moveFiles' a start stop
        | start == stop = return ()
        | otherwise = do
                stopBlock <- MArray.readArray a stop

                if stopBlock == -1
                then
                        moveFiles' a start (pred stop)
                else
                        do
                                startBlock <- MArray.readArray a start
                                if startBlock == -1
                                then
                                        do
                                                MArray.writeArray a start stopBlock
                                                MArray.writeArray a stop (-1)
                                                moveFiles' a (succ start) (pred stop) 
                                else
                                        moveFiles' a (succ start) stop

countConsecutive :: STUArray s Int Int -> Int -> Int -> ST s Int
countConsecutive a i step = do
        block <- MArray.readArray a i
        let nextI = i + step
        bounds <- MArray.getBounds a
        if      | MArray.inRange bounds nextI ->
                        do
                                nextBlock <- MArray.readArray a nextI
                                if nextBlock == block
                                then
                                        do
                                                steps <- countConsecutive a nextI step
                                                return $ 1 + steps
                                else
                                        return 1
                | otherwise -> return 1

findEmpty :: STUArray s Int Int -> Int -> Int -> Int -> ST s (Maybe Int)
findEmpty a i l s = do
        block <- MArray.readArray a i
        blockLength <- countConsecutive a i 1
        let nextI = i + blockLength
        bounds <- MArray.getBounds a
        let nextInBounds = MArray.inRange bounds nextI

        if      | i >= s                           -> return $! Nothing
                | block == -1 && blockLength >= l  -> return $ Just i
                | block /= -1 && nextInBounds      -> findEmpty a nextI l s
                | blockLength <= l && nextInBounds -> findEmpty a nextI l s
                | not nextInBounds                 -> return $! Nothing

moveDefragmenting :: [Int] -> ST s Int
moveDefragmenting bs = do
        let bLength = length bs
        marray <- MArray.newListArray (1, bLength) bs
        moveDefragmenting' marray bLength
        elems <- MArray.getElems marray
        return $ calculateChecksum elems

moveDefragmenting' :: STUArray s Int Int -> Int -> ST s ()
moveDefragmenting' a 1    = return ()
moveDefragmenting' a stop
        | otherwise = do
                stopBlock  <- MArray.readArray a stop
                stopLength <- countConsecutive a stop (-1)
                targetBlock <- findEmpty a 1 stopLength stop

                elems <- MArray.getElems a

                let nextStop = stop - stopLength
                bounds <- MArray.getBounds a
                let nextStopInRange = MArray.inRange bounds nextStop
                
                if      | stopBlock == -1
                                -> moveDefragmenting' a nextStop
                        | Maybe.isJust targetBlock 
                                -> do
                                        let target = Maybe.fromJust targetBlock
                                        mapM_ (\ o -> MArray.writeArray a (stop - o) (-1)) [0..stopLength - 1]
                                        mapM_ (\ o -> MArray.writeArray a (target + o) stopBlock) [0..stopLength - 1]
                                        if nextStopInRange then moveDefragmenting' a nextStop else return ()
                        | nextStopInRange -> moveDefragmenting' a nextStop
                        | otherwise -> return ()
                                

part1 bs = runST $ moveFiles bs
part2 bs = runST $ moveDefragmenting bs

main = getContents
        >>= print
        . (part1 &&& part2)
        . parse

This is so cool, it's going to replace the lambda in my function pipeline for calculating pairs.

Whaaat? It is possible to declare mutliple signatures on one line? 🤯
Does that function (.+.) add tuples/coordinates?

Haskell

I overslept 26 minutes (AoC starts at 06:00 here) which upsets me more than it should.
I thought this one was going to be hard on performance or memory but it was surprisingly easy.

import Control.Arrow hiding (first, second)
import Data.Bifunctor

import Data.Array.Unboxed (UArray)

import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Array.Unboxed as Array

parse :: String -> UArray (Int, Int) Char
parse s = Array.listArray ((1, 1), (n, m)) . filter (/= '\n') $ s :: UArray (Int, Int) Char

        where
                n = takeWhile   (/= '\n') >>> length $ s
                m = List.filter (== '\n') >>> length >>> pred $ s

groupSnd:: Eq b => (a, b) -> (a', b) -> Bool
groupSnd = curry (uncurry (==) <<< snd *** snd)

cartesianProduct xs ys = [(x, y) | x <- xs, y <- ys]

calculateAntitone ((y1, x1), (y2, x2)) = (y1 + dy, x1 + dx)
        where
                dy = y1 - y2
                dx = x1 - x2

antennaCombinations = Array.assocs
        >>> List.filter (snd >>> (/= '.'))
        >>> List.sortOn snd
        >>> List.groupBy groupSnd
        >>> map (map fst)
        >>> map (\ xs -> cartesianProduct xs xs)
        >>> map (filter (uncurry (/=)))

part1 a = antennaCombinations
        >>> List.concatMap (map calculateAntitone)
        >>> List.filter (Array.inRange (Array.bounds a))
        >>> Set.fromList
        >>> Set.size
        $ a

calculateAntitones ((y1, x1), (y2, x2)) = iterate (bimap (+dy) (+dx)) (y1, x1)
        where
                dy = y1 - y2
                dx = x1 - x2

part2 a = antennaCombinations
        >>> List.map (map calculateAntitones)
        >>> List.concatMap (List.concatMap (takeWhile (Array.inRange (Array.bounds a))))
        >>> Set.fromList
        >>> Set.size
        $ a

main = getContents
        >>= print
        . (part1 &&& part2)
        . parse

One optimization some used was to detect loops by only recording the turning points instead of all walked tiles.

I just checked and I have haskell-tools.nvim on my PC but it somehow crashes the default config of the autocompletion for me, which I am too inexperienced to debug. I'll try it nonetheless, since I don't have autocompletion on the laptop anyways, thank you for the suggestion!

I envy emacs for all of its modes, but I don't think I'm relearning the little I know about vi. Thank you for the answer on the versions and building!

0.65 -> 0.43 sounds pretty strong, isn't that a one-fourth speedup?

Edit: I was able to achieve a 30% speed improvement using this on my solution

Haskell

I'm not very proud, I copied my code for part two.

import Control.Arrow hiding (first, second)

import qualified Data.List as List
import qualified Data.Char as Char

parseLine l = (n, os)
        where
                n = read . takeWhile (Char.isDigit) $ l
                os = map read . drop 1 . words $ l

parse :: String -> [(Int, [Int])]
parse s = map parseLine . takeWhile (/= "") . lines $ s

insertOperators target (r:rs) = any (target ==) (insertOperators' r rs)
insertOperators' :: Int -> [Int] -> [Int]
insertOperators' acc []     = [acc]
insertOperators' acc (r:rs) = insertOperators' (acc+r) rs ++ insertOperators' (acc*r) rs

insertOperators2 target (r:rs) = any (target ==) (insertOperators2' r rs)
insertOperators2' :: Int -> [Int] -> [Int]
insertOperators2' acc []     = [acc]
insertOperators2' acc (r:rs) = insertOperators2' (acc+r) rs ++ insertOperators2' (acc*r) rs ++ insertOperators2' concatN rs
        where
                concatN = read (show acc ++ show r)

part1 ls = filter (uncurry insertOperators)
        >>> map fst
        >>> sum
        $ ls
part2 ls = filter (uncurry insertOperators2)
        >>> map fst
        >>> sum
        $ ls

main = getContents >>= print . (part1 &&& part2) . parse

I wanted to this the way yo did, by repeatedly applying functions, but I didn't dare to because I like to mess up and spend some minutes debugging signatures, may I ask what your IDE setup is for the LSP-Hints with Haskell?
Setting up on my PC was a little bit of a pain because it needed matching ghc and ghcide versions, so I hadn't bothered doing it on my Laptop yet.

Haskell

This one was fun, I think I wrote my first lazy infinite loop I cancel out at runtime, lost some time because I had misread the requirements on turning right.

Runs in 45 seconds on my Laptop in power-saver mode, which isn't very fast I fear.

import Control.Arrow hiding (first, second)

import Data.Map (Map)
import Data.Set (Set)
import Data.Bifunctor

import qualified Data.Array.Unboxed as Array
import qualified Data.List as List
import qualified Data.Set as Set
import Data.Array.Unboxed (UArray)

parse :: String -> (UArray (Int, Int) Char, (Int, Int))
parse s = (a, p)
        where
                p = Array.indices 
                        >>> filter ((a Array.!) >>> (== '^'))
                        >>> head
                        $ a
                a = Array.listArray ((1, 1), (n, m)) . filter (/= '\n') $ s
                l = lines s
                (n, m) = (length . head &&& pred . length) l

rotate90 d@(-1, 0) = (0, 1)
rotate90 d@(0,  1) = (1, 0)
rotate90 d@(1,  0) = (0, -1)
rotate90 d@(0, -1) = (-1, 0)

walkGuard :: (UArray (Int, Int) Char) -> (Int, Int) -> (Int, Int) -> [((Int, Int), (Int, Int))]
walkGuard a p d@(dy, dx)
        | not isInBounds                  = []
        | (maybe ' ' id tileAhead) == '#' = (p, d) : walkGuard a p rotatedDirection
        | otherwise                       = (p, d) : walkGuard a updatedPosition d
        where
                isInBounds = Array.inRange (Array.bounds a) p
                updatedPosition = bimap (+dy) (+dx) p
                tileAhead = a Array.!? updatedPosition
                rotatedDirection = rotate90 d

ruleGroup :: Eq a => (a, b) -> (a, b') -> Bool
ruleGroup = curry (uncurry (==) <<< fst *** fst)
                
arrayDisplay a = Array.indices
        >>> List.groupBy ruleGroup
        >>> map (map (a Array.!))
        >>> unlines
        $ a

walkedPositions a p d = walkGuard a p 
        >>> map fst
        >>> Set.fromList
        $ d

isLoop = isLoop' Set.empty
isLoop' _ [] = False
isLoop' s (l:ls)
        | l `Set.member` s = True
        | otherwise = isLoop' (Set.insert l s) ls

part1 (a, p) = walkedPositions a p
        >>> length
        $ (-1, 0)
part2 (a, p) = walkedPositions a p
        >>> Set.toList
        >>> map (, '#')
        >>> map (:[])
        >>> map (a Array.//)
        >>> map (\ a' -> walkGuard a' p (-1, 0))
        >>> filter (isLoop)
        >>> length
        $ (-1, 0)

main = getContents >>= print . (part1 &&& part2) . parse

I was very much unhappy because my previous implementation took 1 second to execute and trashed through 2GB RAM in the process of doing so, I sat down again with some inspiration about the sorting approach.
I am very much happy now, the profiler tells me that most of time is spend in the parsing functions now.

I am also grateful for everyone else doing haskell, this way I learned about Arrays, Bifunctors and Arrows which (I think) improved my code a lot.

Haskell

import Control.Arrow hiding (first, second)

import Data.Map (Map)
import Data.Set (Set)
import Data.Bifunctor

import qualified Data.Maybe as Maybe
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Ord as Ord


parseRule :: String -> (Int, Int)
parseRule s = (read . take 2 &&& read . drop 3) s

replace t r c = if t == c then r else c

parse :: String -> (Map Int (Set Int), [[Int]])
parse s = (map parseRule >>> buildRuleMap $ rules, map (map read . words) updates)
        where
                rules = takeWhile (/= "") . lines $ s
                updates = init . map (map (replace ',' ' ')) . drop 1 . dropWhile (/= "") . lines $ s

middleElement :: [a] -> a
middleElement us = (us !!) $ (length us `div` 2)

ruleGroup :: Eq a => (a, b) -> (a, b') -> Bool
ruleGroup = curry (uncurry (==) <<< fst *** fst)

buildRuleMap :: [(Int, Int)] -> Map Int (Set Int)
buildRuleMap rs = List.sortOn fst
        >>> List.groupBy ruleGroup 
        >>> map ((fst . head) &&& map snd) 
        >>> map (second Set.fromList) 
        >>> Map.fromList 
        $ rs

elementSort :: Map Int (Set Int) -> Int -> Int -> Ordering 
elementSort rs a b
        | Maybe.maybe False (Set.member b) (rs Map.!? a) = LT
        | Maybe.maybe False (Set.member a) (rs Map.!? b) = GT
        | otherwise = EQ

isOrdered rs u = (List.sortBy (elementSort rs) u) == u

part1 (rs, us) = filter (isOrdered rs)
        >>> map middleElement
        >>> sum
        $ us
part2 (rs, us) = filter (isOrdered rs >>> not)
        >>> map (List.sortBy (elementSort rs))
        >>> map middleElement
        >>> sum
        $ us

main = getContents >>= print . (part1 &&& part2) . parse