• 2 Posts
  • 37 Comments
Joined 7 months ago
Cake day: May 9th, 2024
  • VegOwOtenks@lemmy.worldtoAdvent Of Code@programming.dev•🌻 - 2024 DAY 12 SOLUTIONS -🌻English
    2·
    9 hours ago

    Haskell

    Detecting regions is a floodfill. For Part 2, I select all adjacent tiles that are not part of a region and group them by the direction relative to the closest region tile, then group adjacent tiles with the same direction again and count.

    Edit:

    Takes 0.06s

    Reveal Code 
    import Control.Arrow

import Data.Array.Unboxed (UArray)
import Data.Set (Set)
import Data.Map (Map)

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

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

neighborCoordinates (p1, p2) = [(p1-1, p2), (p1, p2-1), (p1, p2+1), (p1+1, p2)]

allNeighbors p a = neighborCoordinates
        >>> filter (UArray.inRange (UArray.bounds a))
        $ p

regionNeighbors p a = allNeighbors p
        >>> filter ((a UArray.!) >>> (== pTile))
        $ a
        where
                pTile = a UArray.! p

floodArea :: Set (Int, Int) -> Set (Int, Int) -> UArray (Int, Int) Char -> Set (Int, Int)
floodArea e o a
        | Set.null o = e
        | otherwise  = floodArea e' o' a
        where
                e' = Set.union e o
                o' = Set.fold (Set.union . Set.fromDistinctAscList .  (filter (`Set.notMember` e')) . (flip regionNeighbors a)) Set.empty o

findRegions garden = findRegions' (Set.fromList . UArray.indices $ garden) garden

findRegions' remainingIndices garden
        | Set.null remainingIndices = []
        | otherwise = removedIndices : findRegions' remainingIndices' garden
        where
                removedIndices = floodArea Set.empty (Set.singleton . Set.findMin $ remainingIndices) garden
                remainingIndices' = Set.difference remainingIndices removedIndices

perimeter region = Set.fold ((+) . length . filter (`Set.notMember` region) . neighborCoordinates) 0 region

part1 rs = map (Set.size &&& perimeter)
        >>> map (uncurry (*))
        >>> sum
        $ rs

turnLeft ( 0, 1) = (-1, 0) -- right
turnLeft ( 0,-1) = ( 1, 0) -- left
turnLeft ( 1, 0) = ( 0, 1) -- down
turnLeft (-1, 0) = ( 0,-1) -- up

turnRight = turnLeft . turnLeft . turnLeft

move (py, px) (dy, dx) = (py + dy, px + dx)

tupleDelta (y1, x1) (y2, x2) = (y1-y2, x1-x2)

isRegionInner region p = all (`Set.member` region) (neighborCoordinates p)

groupEdges d ps
        | Set.null ps = []
        | otherwise   = collectedEdge : groupEdges d ps'
        where
                ps' = Set.difference ps collectedEdge
                collectedEdge = Set.union leftPoints rightPoints
                leftPoints = iterate (move dl)
                        >>> takeWhile (`Set.member` ps)
                        >>> Set.fromList
                        $ currentPoint
                rightPoints = iterate (move dr)
                        >>> takeWhile (`Set.member` ps)
                        >>> Set.fromList
                        $ currentPoint
                currentPoint = Set.findMin ps
                dr = turnRight d
                dl = turnLeft  d

linearPerimeter region = Map.foldr ((+) . length) 0 $ groupedEdges
        where 
                edgeTiles = Set.filter (not . isRegionInner region) region
                regionNeighbors = List.concatMap (\ p -> map (p,). filter (`Set.notMember` region) . neighborCoordinates $ p) . Set.toList $ region
                groupedNeighbors = List.map (uncurry tupleDelta &&& Set.singleton . snd)
                        >>> Map.fromListWith (Set.union)
                        $ regionNeighbors
                groupedEdges = Map.mapWithKey groupEdges
                        $ groupedNeighbors

part2 rs = map (Set.size &&& linearPerimeter)
        >>> map (uncurry (*))
        >>> sum
        $ rs

main = getContents
        >>= print
        . (part1 &&& part2)
        . findRegions
        . parse
  • VegOwOtenks@lemmy.worldtoAdvent Of Code@programming.dev•🪐 - 2024 DAY 11 SOLUTIONS -🪐English
    2·
    2 days ago

    Haskell

    Sometimes I want something mutable, this one takes 0.3s, profiling tells me 30% of my time is spent creating new objects. :/

    import Control.Arrow

import Data.Map.Strict (Map)

import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe

type StoneCache = Map Int Int
type BlinkCache = Map Int StoneCache

parse :: String -> [Int]
parse = lines >>> head >>> words >>> map read

memoizedCountSplitStones :: BlinkCache -> Int -> Int -> (Int, BlinkCache)
memoizedCountSplitStones m 0 _ = (1, m)
memoizedCountSplitStones m i n 
        | Maybe.isJust maybeMemoized = (Maybe.fromJust maybeMemoized, m)
        | n == 0     = do
                let (r, rm) = memoizedCountSplitStones m (pred i) (succ n)
                let rm' = cacheWrite rm i n r
                (r, rm')
        | digitCount `mod` 2 == 0 = do
                let (r1, m1) = memoizedCountSplitStones m  (pred i) firstSplit
                let (r2, m2) = memoizedCountSplitStones m1 (pred i) secondSplit
                let m' = cacheWrite m2 i n (r1+r2)
                (r1 + r2, m')
        | otherwise = do
                let (r, m') = memoizedCountSplitStones m (pred i) (n * 2024)
                let m'' = cacheWrite m' i n r
                (r, m'')
        where
                secondSplit    = n `mod` (10 ^ (digitCount `div` 2))
                firstSplit     = (n - secondSplit) `div` (10 ^ (digitCount `div` 2))
                digitCount     = succ . floor . logBase 10 . fromIntegral $ n
                maybeMemoized  = cacheLookup m i n

foldMemoized :: Int -> (Int, BlinkCache) -> Int -> (Int, BlinkCache)
foldMemoized i (r, m) n = (r + r2, m')
        where
                (r2, m') = memoizedCountSplitStones m i n

cacheWrite :: BlinkCache -> Int -> Int -> Int -> BlinkCache
cacheWrite bc i n r = Map.adjust (Map.insert n r) i bc

cacheLookup :: BlinkCache -> Int -> Int -> Maybe Int
cacheLookup bc i n = do
        sc <- bc Map.!? i
        sc Map.!? n

emptyCache :: BlinkCache
emptyCache = Map.fromList [ (i, Map.empty) | i <- [1..75]]

part1 = foldl (foldMemoized 25) (0, emptyCache)
        >>> fst
part2 = foldl (foldMemoized 75) (0, emptyCache)
        >>> fst

main = getContents
        >>= print
        . (part1 &&& part2)
        . parse
  • VegOwOtenks@lemmy.worldtoAdvent Of Code@programming.dev•🐮 - 2024 DAY 10 SOLUTIONS - 🐮English
    2·
    3 days ago

    Haskell

    Cool task, nothing to optimize

    import Control.Arrow

import Data.Array.Unboxed (UArray)
import Data.Set (Set)

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

parse :: String -> UArray (Int, Int) Int
parse s = UArray.listArray ((1, 1), (n, m)) . map Char.digitToInt . filter (/= '\n') $ s
        where
                n = takeWhile (/= '\n') >>> length $ s
                m = filter (== '\n') >>> length >>> pred $ s

reachableNeighbors :: (Int, Int) -> UArray (Int, Int) Int -> [(Int, Int)]
reachableNeighbors p@(py, px) a = List.filter (UArray.inRange (UArray.bounds a))
        >>> List.filter ((a UArray.!) >>> pred >>> (== (a UArray.! p)))
        $ [(py-1, px), (py+1, px), (py, px-1), (py, px+1)]

distinctTrails :: (Int, Int) -> UArray (Int, Int) Int -> Int
distinctTrails p a
        | a UArray.! p == 9 = 1
        | otherwise = flip reachableNeighbors a
                >>> List.map (flip distinctTrails a)
                >>> sum
                $ p

reachableNines :: (Int, Int) -> UArray (Int, Int) Int -> Set (Int, Int)
reachableNines p a
        | a UArray.! p == 9 = Set.singleton p
        | otherwise = flip reachableNeighbors a
                >>> List.map (flip reachableNines a)
                >>> Set.unions
                $ p

findZeros = UArray.assocs
        >>> filter (snd >>> (== 0))
        >>> map fst

part1 a = findZeros
        >>> map (flip reachableNines a)
        >>> map Set.size
        >>> sum
        $ a
part2 a = findZeros
        >>> map (flip distinctTrails a)
        >>> sum
        $ a

main = getContents
        >>= print
        . (part1 &&& part2)
        . parse
  • VegOwOtenks@lemmy.worldtoAdvent Of Code@programming.dev•💿 - 2024 DAY 9 SOLUTIONS -💿
    2·
    3 days ago

    Thank you for the detailed explanation!, it made me realize that our solutions are very similar. Instead of keeping a Dict[Int, List[Int]] where the value list is ordered I have a Dict[Int, Tree[Int]] which allows for easy (and fast!) lookup due to the nature of trees. (Also lists in haskell are horrible to mutate)

    I also apply the your technique of only processing each file once, instead of calculating the checksum afterwards on the entire list of file blocks I calculate it all the time whenever I process a file. Using some maths I managed to reduce the sum to a constant expression.

  • VegOwOtenks@lemmy.worldtoAdvent Of Code@programming.dev•💿 - 2024 DAY 9 SOLUTIONS -💿English
    4·
    3 days ago

    Haskell

    This was fun, I optimized away quite a bit, as a result it now runs in 0.04s for both parts together on my 2016 laptop.

    In part 1 I just run through the array with a start- and an end-index whilst summing up the checksum the entire time.
    In part 2 I build up Binary Trees of Free Space which allow me to efficiently search for and insert free spaces when I start traversing the disk from the back. Marking the moved files as free is omitted because the checksum is calculated for every file that is moved or not moved directly.

    Code 
    import Control.Monad
import Data.Bifunctor

import Control.Arrow hiding (first, second)

import Data.Map (Map)
import Data.Set (Set)
import Data.Array.Unboxed (UArray)

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Ord as Ord
import qualified Data.List as List
import qualified Data.Char as Char
import qualified Data.Maybe as Maybe
import qualified Data.Array.Unboxed as UArray

toNumber = flip (-) (Char.ord '0') <<< Char.ord 

type FileID = Int
type FileLength = Int
type DiskPosition = Int
type File = (FileID, (DiskPosition, FileLength))
type EmptyMap = Map FileLength (Set DiskPosition)

readDisk :: DiskPosition -> [(Bool, FileLength)] -> [(Bool, (DiskPosition, FileLength))]
readDisk _ [] = []
readDisk o ((True, l):fs)  = (True, (o, l))  : readDisk (o+l) fs
readDisk o ((False, l):fs) = (False, (o, l)) : readDisk (o+l) fs

parse2 :: String -> ([File], EmptyMap)
parse2 s = takeWhile (/= '\n')
        >>> map toNumber
        >>> zip (cycle [True, False]) -- True is File, False is empty
        >>> readDisk 0
        >>> List.partition fst
        >>> join bimap (map snd)
        >>> first (zip [0..])
        >>> first List.reverse
        >>> second (filter (snd >>> (/= 0)))
        >>> second (List.sortOn snd)
        >>> second (List.groupBy (curry $ (snd *** snd) >>> uncurry (==)))
        >>> second (List.map (snd . head &&& map fst))
        >>> second (List.map (second Set.fromDistinctAscList))
        >>> second Map.fromDistinctAscList
        $ s

maybeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
maybeMinimumBy _ [] = Nothing
maybeMinimumBy f as = Just $ List.minimumBy f as

fileChecksum fid fpos flen = fid * (fpos * flen + ((flen-1) * (flen-1) + (flen-1)) `div` 2)

type Checksum = Int
moveFilesAccumulate :: (Checksum, EmptyMap) -> File -> (Checksum, EmptyMap)
moveFilesAccumulate (check, spaces) (fid, (fpos, flen)) = do
        let bestFit = Map.map (Set.minView)
                >>> Map.toList
                >>> List.filter (fst >>> (>= flen))
                >>> List.filter (snd >>> Maybe.isJust)
                >>> List.map (second Maybe.fromJust) -- [(FileLength, (DiskPosition, Set DiskPosition))]
                >>> List.filter (snd >>> fst >>> (< fpos))
                >>> maybeMinimumBy (\ (_, (p, _)) (_, (p', _)) -> Ord.compare p p')
                $ spaces

        case bestFit of
                Nothing -> (check + fileChecksum fid fpos flen, spaces)
                Just (spaceLength, (spacePosition, remainingSet)) -> do
                        

                        -- remove the old empty entry by replacing the set
                        let updatedMap  = Map.update (const $! Just remainingSet) spaceLength spaces

                        -- add the remaining space, if any
                        let remainingSpace = spaceLength - flen
                        let remainingSpacePosition = spacePosition + flen
                        let updatedMap' = if remainingSpace == 0 then updatedMap else Map.insertWith (Set.union) remainingSpace (Set.singleton remainingSpacePosition) updatedMap

                        (check + fileChecksum fid spacePosition flen, updatedMap')

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

moveBlocksAccumulate :: Int -> Int -> UArray Int Int -> Int
moveBlocksAccumulate start stop array
        | start      == stop   = if startBlock == -1 then 0 else start * startBlock
        | start      >  stop   = 0
        | stopBlock  == -1     = moveBlocksAccumulate start (stop - 1) array
        | startBlock == -1     = movedChecksum + moveBlocksAccumulate (start + 1) (stop - 1) array
        | startBlock /= -1     = startChecksum + moveBlocksAccumulate (start + 1) stop array
        where
                startBlock    = array UArray.! start
                stopBlock     = array UArray.! stop
                movedChecksum = stopBlock * start
                startChecksum = startBlock * start

part1 a = moveBlocksAccumulate 0 arrayLength a
        where
                (_, arrayLength) = UArray.bounds a
part2 (files, spaces) = foldl moveFilesAccumulate (0, spaces)
        >>> fst
        $ files

main = getContents
        >>= print
        . (part1 . parse1 &&& part2 . parse2)
  • VegOwOtenks@lemmy.worldtoAdvent Of Code@programming.dev•💿 - 2024 DAY 9 SOLUTIONS -💿English
    2·
    3 days ago

    Haskell

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

    Spoiler 
    {-# 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
  • VegOwOtenks@lemmy.worldtoAdvent Of Code@programming.dev•🛜 - 2024 DAY 8 SOLUTIONS -🛜English
    5·
    5 days ago

    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