• 0 Posts
  • 6 Comments
Joined 1 year ago
cake
Cake day: July 1st, 2023

help-circle
  • Haskell

    import Data.ByteString.Char8 (unpack)
    import Data.Char (isDigit, isHexDigit)
    import Relude
    import qualified Relude.Unsafe as Unsafe
    import Text.ParserCombinators.ReadP
    
    data Dir = R | D | L | U deriving (Show, Eq)
    
    type Pos = (Int, Int)
    
    data Action = Action Dir Int deriving (Show, Eq)
    
    parse :: ByteString -> Maybe [(Action, Action)]
    parse = fmap fst . viaNonEmpty last . readP_to_S (sepBy1 parseAction (char '\n') <* char '\n' <* eof) . unpack
      where
        parseAction = do
          dir <- choice [U <$ char 'U', D <$ char 'D', L <$ char 'L', R <$ char 'R'] <* char ' '
          x <- Unsafe.read <$> munch1 isDigit <* char ' '
          y <- char '(' *> char '#' *> (Unsafe.read . ("0x" ++) <$> count 5 (satisfy isHexDigit))
          dir' <- choice [R <$ char '0', D <$ char '1', L <$ char '2', U <$ char '3'] <* char ')'
          return (Action dir x, Action dir' y)
    
    vertices :: [Action] -> [Pos]
    vertices = scanl' (flip step) origin
      where
        step (Action U n) = first $ subtract n
        step (Action D n) = first (+ n)
        step (Action L n) = second $ subtract n
        step (Action R n) = second (+ n)
    
    origin :: Pos
    origin = (0, 0)
    
    area, perimeter, solve :: [Action] -> Int
    area a = (`div` 2) . abs . sum $ zipWith (-) x y
      where
        (p, rp) = (origin :) &&& (++ [origin]) $ vertices a
        x = zipWith (*) (fst <$> p) (snd <$> rp)
        y = zipWith (*) (snd <$> p) (fst <$> rp)
    perimeter = sum . fmap (\(Action _ n) -> n)
    solve = area &&& (`div` 2) . perimeter >>> uncurry (+) >>> succ
    
    part1, part2 :: [(Action, Action)] -> Int
    part1 = solve . fmap fst
    part2 = solve . fmap snd
    

  • Haskell

    import Data.Array.Unboxed
    import qualified Data.ByteString.Char8 as BS
    import Data.Char (digitToInt)
    import Data.Heap hiding (filter)
    import qualified Data.Heap as H
    import Relude
    
    type Pos = (Int, Int)
    
    type Grid = UArray Pos Int
    
    data Dir = U | D | L | R deriving (Eq, Ord, Show, Enum, Bounded, Ix)
    
    parse :: ByteString -> Maybe Grid
    parse input = do
      let l = fmap (fmap digitToInt . BS.unpack) . BS.lines $ input
          h = length l
      w <- fmap length . viaNonEmpty head $ l
      pure . listArray ((0, 0), (w - 1, h - 1)) . concat $ l
    
    move :: Dir -> Pos -> Pos
    move U = first pred
    move D = first succ
    move L = second pred
    move R = second succ
    
    nextDir :: Dir -> [Dir]
    nextDir U = [L, R]
    nextDir D = [L, R]
    nextDir L = [U, D]
    nextDir R = [U, D]
    
    -- position, previous direction, accumulated loss
    type S = (Int, Pos, Dir)
    
    doMove :: Grid -> Dir -> S -> Maybe S
    doMove g d (c, p, _) = do
      let p' = move d p
      guard $ inRange (bounds g) p'
      pure (c + g ! p', p', d)
    
    doMoveN :: Grid -> Dir -> Int -> S -> Maybe S
    doMoveN g d n = foldl' (>=>) pure . replicate n $ doMove g d
    
    doMoves :: Grid -> [Int] -> S -> Dir -> [S]
    doMoves g r s d = mapMaybe (flip (doMoveN g d) s) r
    
    allMoves :: Grid -> [Int] -> S -> [S]
    allMoves g r s@(_, _, prev) = nextDir prev >>= doMoves g r s
    
    solve' :: Grid -> [Int] -> UArray (Pos, Dir) Int -> Pos -> MinHeap S -> Maybe Int
    solve' g r distances target h = do
      ((acc, pos, dir), h') <- H.view h
    
      if pos == target
        then pure acc
        else do
          let moves = allMoves g r (acc, pos, dir)
              moves' = filter (\(acc, p, d) -> acc < distances ! (p, d)) moves
              distances' = distances // fmap (\(acc, p, d) -> ((p, d), acc)) moves'
              h'' = foldl' (flip H.insert) h' moves'
          solve' g r distances' target h''
    
    solve :: Grid -> [Int] -> Maybe Int
    solve g r = solve' g r (emptyGrid ((lo, minBound), (hi, maxBound))) hi (H.singleton (0, (0, 0), U))
      where
        (lo, hi) = bounds g
        emptyGrid = flip listArray (repeat maxBound)
    
    part1, part2 :: Grid -> Maybe Int
    part1 = (`solve` [1 .. 3])
    part2 = (`solve` [4 .. 10])
    

  • Haskell

    A bit of a mess, I probably shouldn’t have used RWS …

    import Control.Monad.RWS
    import Control.Parallel.Strategies
    import Data.Array
    import qualified Data.ByteString.Char8 as BS
    import Data.Foldable (Foldable (maximum))
    import Data.Set
    import Relude
    
    data Cell = Empty | VertSplitter | HorizSplitter | Slash | Backslash deriving (Show, Eq)
    
    type Pos = (Int, Int)
    
    type Grid = Array Pos Cell
    
    data Direction = N | S | E | W deriving (Show, Eq, Ord)
    
    data BeamHead = BeamHead
      { pos :: Pos,
        dir :: Direction
      }
      deriving (Show, Eq, Ord)
    
    type Simulation = RWS Grid (Set Pos) (Set BeamHead)
    
    next :: BeamHead -> BeamHead
    next (BeamHead p d) = BeamHead (next' d p) d
      where
        next' :: Direction -> Pos -> Pos
        next' direction = case direction of
          N -> first pred
          S -> first succ
          E -> second succ
          W -> second pred
    
    advance :: BeamHead -> Simulation [BeamHead]
    advance bh@(BeamHead position direction) = do
      grid <- ask
      seen <- get
    
      if inRange (bounds grid) position && bh `notMember` seen
        then do
          tell $ singleton position
          modify $ insert bh
          pure . fmap next $ case (grid ! position, direction) of
            (Empty, _) -> [bh]
            (VertSplitter, N) -> [bh]
            (VertSplitter, S) -> [bh]
            (HorizSplitter, E) -> [bh]
            (HorizSplitter, W) -> [bh]
            (VertSplitter, _) -> [bh {dir = N}, bh {dir = S}]
            (HorizSplitter, _) -> [bh {dir = E}, bh {dir = W}]
            (Slash, N) -> [bh {dir = E}]
            (Slash, S) -> [bh {dir = W}]
            (Slash, E) -> [bh {dir = N}]
            (Slash, W) -> [bh {dir = S}]
            (Backslash, N) -> [bh {dir = W}]
            (Backslash, S) -> [bh {dir = E}]
            (Backslash, E) -> [bh {dir = S}]
            (Backslash, W) -> [bh {dir = N}]
        else pure []
    
    simulate :: [BeamHead] -> Simulation ()
    simulate heads = do
      heads' <- foldMapM advance heads
      unless (Relude.null heads') $ simulate heads'
    
    runSimulation :: BeamHead -> Grid -> Int
    runSimulation origin g = size . snd . evalRWS (simulate [origin]) g $ mempty
    
    part1, part2 :: Grid -> Int
    part1 = runSimulation $ BeamHead (0, 0) E
    part2 g = maximum $ parMap rpar (`runSimulation` g) possibleInitials
      where
        ((y0, x0), (y1, x1)) = bounds g
        possibleInitials =
          join
            [ [BeamHead (y0, x) S | x <- [x0 .. x1]],
              [BeamHead (y1, x) N | x <- [x0 .. x1]],
              [BeamHead (y, x0) E | y <- [y0 .. y1]],
              [BeamHead (y, x1) W | y <- [y0 .. y1]]
            ]
    
    parse :: ByteString -> Maybe Grid
    parse input = do
      let ls = BS.lines input
          h = length ls
      w <- BS.length <$> viaNonEmpty head ls
      mat <- traverse toCell . BS.unpack $ BS.concat ls
      pure $ listArray ((0, 0), (h - 1, w - 1)) mat
      where
        toCell '.' = Just Empty
        toCell '|' = Just VertSplitter
        toCell '-' = Just HorizSplitter
        toCell '/' = Just Slash
        toCell '\\' = Just Backslash
        toCell _ = Nothing
    
    

  • Haskell

    import Data.Array
    import qualified Data.ByteString.Char8 as BS
    import Data.Char (isAlpha, isDigit)
    import Relude
    import qualified Relude.Unsafe as Unsafe
    import Text.ParserCombinators.ReadP hiding (get)
    
    hash :: String -> Int
    hash = foldl' (\a x -> (a + x) * 17 `mod` 256) 0 . fmap ord
    
    part1 :: ByteString -> Int
    part1 = sum . fmap (hash . BS.unpack) . BS.split ',' . BS.dropEnd 1
    
    -- Part 2
    
    type Problem = [Operation]
    
    type S = Array Int [(String, Int)]
    
    data Operation = Set String Int | Remove String deriving (Show)
    
    parse :: BS.ByteString -> Maybe Problem
    parse = fmap fst . viaNonEmpty last . readP_to_S parse' . BS.unpack
      where
        parse' = sepBy parseOperation (char ',') <* char '\n' <* eof
        parseOperation =
          munch1 isAlpha
            >>= \label -> (Remove label <$ char '-') +++ (Set label . Unsafe.read <$> (char '=' *> munch1 isDigit))
    
    liftOp :: Operation -> Endo S
    liftOp (Set label v) = Endo $ \s ->
      let (b, a) = second (drop 1) $ span ((/= label) . fst) (s ! hash label)
       in s // [(hash label, b <> [(label, v)] <> a)]
    liftOp (Remove l) = Endo $ \s -> s // [(hash l, filter ((/= l) . fst) (s ! hash l))]
    
    score :: S -> Int
    score m = sum $ join [(* (i + 1)) <$> zipWith (*) [1 ..] (snd <$> (m ! i)) | i <- [0 .. 255]]
    
    part2 :: ByteString -> Maybe Int
    part2 input = do
      ops <- appEndo . foldMap liftOp . reverse <$> parse input
      pure . score . ops . listArray (0, 255) $ repeat []
    

  • Haskell

    Managed to do part1 in one line using ByteString operations:

    import Control.Monad
    import qualified Data.ByteString.Char8 as BS
    
    part1 :: IO Int
    part1 =
      sum
        . ( BS.transpose . BS.split '\n'
              >=> fmap succ
              . BS.elemIndices 'O' . BS.reverse . BS.intercalate "#"
              . fmap (BS.reverse . BS.sort) . BS.split '#'
          )
        <$> BS.readFile "inp"
    

    Part 2

    {-# LANGUAGE NumericUnderscores #-}
    
    import qualified Data.ByteString.Char8 as BS
    import qualified Data.Map as M
    import Relude
    
    type Problem = [ByteString]
    
    -- We apply rotation so that north is to the right, this makes
    -- all computations easier since we can just sort the rows.
    parse :: ByteString -> Problem
    parse = rotate . BS.split '\n'
    
    count :: Problem -> [[Int]]
    count = fmap (fmap succ . BS.elemIndices 'O')
    
    rotate, move, rotMov, doCycle :: Problem -> Problem
    rotate = fmap BS.reverse . BS.transpose
    move = fmap (BS.intercalate "#" . fmap BS.sort . BS.split '#')
    rotMov = rotate . move
    doCycle = rotMov . rotMov . rotMov . rotMov
    
    doNcycles :: Int -> Problem -> Problem
    doNcycles n = foldl' (.) id (replicate n doCycle)
    
    findCycle :: Problem -> (Int, Int)
    findCycle = go 0 M.empty
      where
        go :: Int -> M.Map Problem Int -> Problem -> (Int, Int)
        go n m p =
          let p' = doCycle p
           in case M.lookup p' m of
                Just n' -> (n', n + 1)
                Nothing -> go (n + 1) (M.insert p' n m) p'
    
    part1, part2 :: ByteString -> Int
    part1 = sum . join . count . move . parse
    part2 input =
      let n = 1_000_000_000
          p = parse input
          (s, r) = findCycle p
          numRots = s + ((n - s) `mod` (r - s - 1))
       in sum . join . count $ doNcycles numRots p
    

  • Haskell

    Abused ParserCombinators for the first part. For the second, I took quite a while to figure out dynamic programming in Haskell.

    Solution
    module Day12 where
    
    import Data.Array
    import Data.Char (isDigit)
    import Data.List ((!!))
    import Relude hiding (get, many)
    import Relude.Unsafe (read)
    import Text.ParserCombinators.ReadP
    
    type Spring = (String, [Int])
    
    type Problem = [Spring]
    
    parseStatus :: ReadP Char
    parseStatus = choice $ char <$> ".#?"
    
    parseSpring :: ReadP Spring
    parseSpring = do
      status <- many1 parseStatus <* char ' '
      listFailed <- (read <$> munch1 isDigit) `sepBy` char ','
      return (status, listFailed)
    
    parseProblem :: ReadP Problem
    parseProblem = parseSpring `sepBy` char '\n'
    
    parse :: ByteString -> Maybe Problem
    parse = fmap fst . viaNonEmpty last . readP_to_S parseProblem . decodeUtf8
    
    good :: ReadP ()
    good = choice [char '.', char '?'] $> ()
    
    bad :: ReadP ()
    bad = choice [char '#', char '?'] $> ()
    
    buildParser :: [Int] -> ReadP ()
    buildParser l = do
      _ <- many good
      sequenceA_ $ intersperse (many1 good) [count x bad | x <- l]
      _ <- many good <* eof
    
      return ()
    
    combinations :: Spring -> Int
    combinations (s, l) = length $ readP_to_S (buildParser l) s
    
    part1, part2 :: Problem -> Int
    part1 = sum . fmap combinations
    part2 = sum . fmap (combinations' . toSpring' . bimap (join . intersperse "?" . replicate 5) (join . replicate 5))
    
    run1, run2 :: FilePath -> IO Int
    run1 f = readFileBS f >>= maybe (fail "parse error") (return . part1) . parse
    run2 f = readFileBS f >>= maybe (fail "parse error") (return . part2) . parse
    
    data Status = Good | Bad | Unknown deriving (Eq, Show)
    
    type Spring' = ([Status], [Int])
    
    type Problem' = [Spring']
    
    toSpring' :: Spring -> Spring'
    toSpring' (s, l) = (fmap toStatus s, l)
      where
        toStatus :: Char -> Status
        toStatus '.' = Good
        toStatus '#' = Bad
        toStatus '?' = Unknown
        toStatus _ = error "impossible"
    
    isGood, isBad :: Status -> Bool
    isGood Bad = False
    isGood _ = True
    isBad Good = False
    isBad _ = True
    
    combinations' :: Spring' -> Int
    combinations' (s, l) = t ! (0, 0)
      where
        n = length s
        m = length l
    
        t = listArray ((0, 0), (n, m)) [f i j | i <- [0 .. n], j <- [0 .. m]]
    
        f :: Int -> Int -> Int
        f n' m'
          | n' >= n = if m' >= m then 1 else 0
          | v == Unknown = tGood + tBad
          | v == Good = tGood
          | v == Bad = tBad
          | otherwise = error "impossible"
          where
            v = s !! n'
            x = l !! m'
    
            ss = drop n' s
    
            (bads, rest) = splitAt x ss
            badsDelimited = maybe True isGood (viaNonEmpty head rest)
            off = if null rest then 0 else 1
    
            tGood = t ! (n' + 1, m')
    
            tBad =
              if m' + 1 <= m && length bads == x && all isBad bads && badsDelimited
                then t ! (n' + x + off, m' + 1)
                else 0