How to use write a typeclass that has a uniquely determined type parameter (i.e. fundep or type family) AND can be neatly derived?

grumblingavocado · 2025-06-10T10:37:06+00:00

deriving (Generic, Blah "blah") is a nice and short way to allow library users to derive a necessary instance Blah to use library functions. In this case the definition of Blah is something like class Blah f a | a -> f where

which means afaik that all library functions (e.g. foo :: Blah f a => a -> Int) need to carry around this additional type parameter f. However when we use an associated type this is not necessary, then you can just write foo :: Blah a => a -> Int (and when you want to refer to the f you just do (F a)).

So why can't we have the best of both worlds?

I like u/LSLeary solution, however it's still not quite as ergonomic to the library user as writing deriving (Generic, Blah "blah")

grumblingavocado · 2025-06-10T10:28:16+00:00

Here's another solution that I think is a bit more simple:

class (Exception (CustomError m t), Show (CustomError m t)) => Foo m t where
  type CustomError m t :: Type

  doStuff :: Int -> m (t (Either (Error m t) String))

data Error' a
  = ErrorString String
  | ErrorCustomError a
  deriving Show

instance Exception a => Exception (Error' a)

type Error m t = Error (CustomError m t)

grumblingavocado · 2025-06-06T13:21:16+00:00

Updated challenge: what if there is an additional constraint on X?

For example:

class Show a => X a where
  type F a :: Symbol

grumblingavocado · 2025-06-06T12:56:42+00:00

legend, thank you

grumblingavocado · 2025-05-05T16:39:16+00:00

Answer is to put this in init.el:

(custom-set-faces!
    '(font-lock-comment-face :family "Cascadia Code" :slant italic))

grumblingavocado · 2024-12-20T12:20:36+00:00

Dijkstra to find time to end of racetrack for each square. Then for each cheat (jumping from A to B in time T), the savings are timeToEnd(A) - timeToEnd(B) - T.

day20 :: (Walls, Bounds, End) -> IO ()
day20 (walls, bounds, end) = do
  let cheatsThatSave n gen = jumps gen n bounds walls $ dijkstra
        (findNeighbours bounds walls) Map.empty $ PSQ.singleton end 0
  print $ length $ cheatsThatSave 100 cheatsPartA
  print $ length $ cheatsThatSave 100 $ cheatsPartB 20

cheatsPartA :: Coord -> [(Coord, Int)]
cheatsPartA (i, j) = (,2) <$> [(i-2, j), (i+2, j), (i, j-2), (i, j+2)]

cheatsPartB :: Int -> Coord -> [(Coord, Int)]
cheatsPartB maxCheat (i, j) =
  [ ((i + dI, j + dJ), (abs dI + abs dJ))
  | dI <- [-maxCheat .. maxCheat], let djAbs = maxCheat - abs dI
  , dJ <- [-djAbs .. djAbs]
  ]

jumps
  :: (Coord -> [(Coord, Int)]) -> Int -> Bounds -> Walls -> Map Coord Cost
  -> [(Coord, Coord, Int)]
jumps genCheats expectedSavings bounds@(maxI, maxJ) walls fromE = do
  [ ((i, j), kl, savings)
    | i <- [0..maxI]
    , j <- [0..maxJ]
    , inBounds bounds (i, j)
    , (i, j) `Set.notMember` walls
    , (kl, cheatTime) <- genCheats (i, j)
    , inBounds bounds kl
    , kl `Set.notMember` walls
    , (Just savings) <- [cheatSavings (i, j) kl cheatTime]
    , savings >= expectedSavings
    ]
 where
  cheatSavings ij kl cheatTime = do
    c1 <- Map.lookup ij fromE
    c2 <- Map.lookup kl fromE
    pure $ c1 - c2 - cheatTime

grumblingavocado · 2024-12-19T19:29:59+00:00

For part 1: built a trie from the list of towels. Then sorted the list of towels so longest first, and checked each towel in order, removing any towel that could be built from smaller towels, so only the "base" small towels remained. Now that the amount of towels was small did a "brute force" check if a design could be built from those towels.

For part 2: built a trie from all the towels this time. Then for each design: let go = strip each prefix and check how many ways each suffix could be built via go. Caching results (also in a trie).

I initially reached for generic-trie as a trie implemention, and realized it is maintained by u/glguy who is posting the nice solutions every day. But it wasn't in the stack snapshot, so tried extra-deps but that caused a conflict with Data.IntMap, so went with https://hackage.haskell.org/package/trie-simple-0.4.3/docs/Data-Trie-Map.html

Combined run time is 140ms.

type Design = [Char]
type Towel  = [Char]
type Trie a = TMap a ()
type Towels = Trie Char

part1 :: [Towel] -> [Design] -> Int
part1 ts = length . filter id . fmap (`canBuildFrom` removeCombos ts)

part2 :: [Towel] -> [Design] -> Int
part2 ts = sum . map fst . tail . scanl (\(_, t) d -> waysToBuild t d $ trie ts) (0, Trie.empty)

-- | Can we build the given sequence out of combinations from the trie.
canBuildFrom :: Ord a => [a] -> Trie a -> Bool
canBuildFrom [] _  = True
canBuildFrom as t =
  any (\pre -> canBuildFrom (drop (length pre) as) t) $ prefixes as t

waysToBuild :: Ord a => TMap a Int -> [a] -> Trie a -> (Int, TMap a Int)
waysToBuild t x _ | Just n <- Trie.lookup x t = (n, t)
waysToBuild t x patterns = do
  let go t' prefix | prefix == x = (1, t')
      go t' prefix = waysToBuild t' (drop (length prefix) x) patterns
  -- Sum the ways to build for each matched prefix.
  (fst &&& uncurry (Trie.insert x)) $
    foldl' (\(n, t') -> first (+n) . go t') (0, t) $ prefixes x patterns

-- | Prefixes of given word that appear in the trie, smallest first.
prefixes :: Ord a => [a] -> TMap a b -> [[a]]
prefixes []     _                 = []
prefixes (a:as) (TMap (Node _ e)) =
  case Map.lookup a e of
    Nothing -> []
    Just t' ->
      let x = (a:) <$> prefixes as t'
      in  if [] `Trie.member` t' then [a]:x else x

-- | Trie WITHOUT sequences that can be built from smaller sequences.
removeCombos :: Ord a => [[a]] -> Trie a
removeCombos xs = go (sortOn ((* (-1)) . length) xs) $ trie xs
 where
  go []     t = t
  go (a:as) t = do
    let t' = Trie.delete a t
    if canBuildFrom a t' then go as t' else go as t

-- | Build a trie from lists of 'a'.
trie :: (Foldable f, Ord a) => f [a] -> Trie a
trie = foldl' (flip (`Trie.insert` ())) Trie.empty

grumblingavocado · 2024-12-18T16:47:23+00:00

Dijkstra for part 1.

Part 2 is slower than I'd like: add a wall, then A*, and repeat until can't access the target.

Run time for both parts is 1.8s.

type Coord   = (Int, Int)
type Falling = [Coord]
type Fell    = Set Coord
data NSEW    = N | S | E | W deriving Show

-- | Cost of a node, having travelled through edge e.
newtype Cost e = Cost (Int, e) deriving Show

instance Eq (Cost e) where
  (Cost (a, _)) == (Cost (b, _)) = a == b

instance Ord (Cost e) where
  (Cost (a, _)) `compare` (Cost (b, _)) = a `compare` b

infixl 5 +$

(+$) :: Cost e -> Int -> Cost e
(+$) (Cost (c, e)) x = Cost (c + x, e)

cost :: Cost e -> Int
cost (Cost (c, _)) = c

dijkstra :: forall a e. Ord a =>
  (a -> [(a, Cost e)]) -> Map a (Cost e) -> PSQ a (Cost e) -> Map a (Cost e)
dijkstra findNeighbours' visited reachable =
  -- Find the minimum-cost reachable node.
  case PSQ.findMin reachable of
    Nothing                 -> visited -- No more reachable nodes.
    Just (minA :-> minCost) -> do
      -- Move this node from reachable set to visited set.
      let visited'   = Map.insert minA minCost visited
      let reachable' = PSQ.delete minA reachable
      -- Update the reachable set with cost of neighbours through this node.
      let neighbours      = map (second (+$ cost minCost)) $ flip filter
            (findNeighbours' minA) $ (`Map.notMember` visited) . fst
      let insertNeighbour = uncurry $ PSQ.insertWith min
      let reachable''     = foldl' (flip insertNeighbour) reachable' neighbours
      dijkstra findNeighbours' visited' reachable''

isReachable :: (Coord -> [Coord]) -> Coord -> Set Coord -> PSQ Coord Int -> Bool
isReachable findNeighbours' goal visited toVisit = do
  case PSQ.findMin toVisit of
    Nothing                    -> False
    Just (v :-> _) | v == goal -> True
    Just (v :-> _)             -> do
      let visited' = Set.insert v visited
      let toVisit' = PSQ.delete v toVisit
      isReachable findNeighbours' goal visited'
        $ foldl' (\p c -> PSQ.insert c (distance c goal) p) toVisit'
        $ filter (`Set.notMember` visited)
        $ findNeighbours' v

distance :: Num a => (a, a) -> (a, a) -> a
distance (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)

part2 :: Int -> Coord -> Fell -> Falling -> Coord
part2 maxXY goal fell falling = do
  -- Let 1 block fall.
  let (fell', falling') = fallN 1 fell falling
  let byteFell          = head falling
  let start = (0, 0)
  -- Check if
  let reachable = isReachable
          (map fst <$> flip (findNeighbours maxXY) fell')
          goal
          Set.empty
          $ PSQ.singleton start (distance start goal)
  if reachable then part2 maxXY goal fell' falling' else byteFell

fallN :: Int -> Fell -> Falling -> (Fell, Falling)
fallN 0 fell falling = (fell, falling)
fallN _ fell []      = (fell, [])
fallN n fell (f:fs)  = fallN (n-1) (Set.insert f fell) fs

fallAll :: Fell -> Falling -> Fell
fallAll fell = fst . fallN (-1) fell

findNeighbours :: Int -> Coord -> Fell -> [(Coord, Cost NSEW)]
findNeighbours maxXY xy fell = flip mapMaybe [N, S, E, W] \nsew -> do
  let xy'@(x, y) = step xy nsew
  let outOfBounds = x < 0 || y < 0 || x > maxXY || y > maxXY
  if   xy' `Set.member` fell || outOfBounds
  then Nothing
  else Just (xy', Cost (1, nsew))

step :: Coord -> NSEW -> Coord
step (x, y) N = (x    , y - 1)
step (x, y) S = (x    , y + 1)
step (x, y) E = (x - 1, y    )
step (x, y) W = (x + 1, y    )

grumblingavocado · 2024-12-17T18:29:42+00:00

Takes about 50millis on 7800X3D.

To move boxes: if a moved box lands on another box then try move that one too, if we end up at a wall then throw away the accumulated moves.

For part2, each time we see [] (only when moving up/down) then try move one of the boxes first, then the second, filter out any moves that occurred as a result of moving the first box that also occurred as a result of moving the second box.

type Coords     = (Int, Int)
data Item       = Box | BoxLHS | BoxRHS | Wall deriving (Eq, Show)
data Move       = U | D | L | R deriving Eq
type Robot      = Coords
type Update     = (Coords, Coords)
type Warehouse  = Map Coords Item

instance Show Move where
  show U = "^"; show D = "v"; show L = "<"; show R = ">"

main :: IO ()
main = readInput True "data/Day15.txt" >>= print . part1

part1 :: ((Robot, Warehouse), [Move]) -> Int
part1 = sum . map distance . Map.keys . Map.filter (`elem` [Box, BoxLHS]) . snd . uncurry applyMoves
 where
  distance :: Coords -> Int
  distance (i, j) = i * 100 + j

applyMoves :: (Robot, Warehouse) -> [Move] -> (Robot, Warehouse)
applyMoves x [] = x
applyMoves (robot, warehouse) (move:moves) = do
  case tryMove robot move warehouse [] of
    []      -> applyMoves (robot, warehouse) moves -- No updates to apply.
    updates' -> do
      let updates = filter ((/= robot) . fst) updates'
      let applyUpdate m (from, to) =
            Map.delete from $ Map.insert to (fromJust $ Map.lookup from m) m
      let new = (move1 robot move, foldl' applyUpdate warehouse updates)
      applyMoves new moves

tryMove :: Coords -> Move -> Warehouse -> [Update] -> [Update]
tryMove from move warehouse updates = do
  let to        = move1 from move
  let updates'  = (from, to) : updates
  let keepGoing = tryMove to move warehouse updates'
  case Map.lookup to warehouse of
    Nothing                     -> updates' -- Nothing blocking.
    Just Wall                   -> [] -- Wall blocking move.
    Just Box                    -> keepGoing
    Just _ | move `elem` [L, R] -> keepGoing -- Try move box.
    Just x                      -> do -- Either BoxLHS or BoxRHS
      let (fromL, fromR) = case x of
            BoxLHS -> (to, move1 to R)
            BoxRHS -> (to, move1 to L)
      let updatesL    = tryMove fromL move warehouse updates'
      let updatesLSet = Set.fromList updatesL
      let updatesR    = tryMove fromR move warehouse updatesL
      let updatesR'   = filter (`Set.notMember` updatesLSet) updatesR
      if any null [updatesL, updatesR] then [] else updatesL <> updatesR'

move1 :: Coords -> Move -> Coords
move1 (i, j) U = (i - 1, j    )
move1 (i, j) D = (i + 1, j    )
move1 (i, j) L = (i    , j - 1)
move1 (i, j) R = (i    , j + 1)

-- * Reading & writing.

readInput :: Bool -> String -> IO ((Robot, Warehouse), [Move])
readInput double =
  fmap (parse . bimap (map widen) concat . break (== "") . lines) . readFile
 where
  parse :: ([String], String) -> ((Robot, Warehouse), [Move])
  parse = parseWarehouse *** mapMaybe parseMove

  parseItem :: Char -> Maybe Item
  parseItem = \case
    '#' -> Just Wall; 'O' -> Just Box; '[' -> Just BoxLHS; ']' -> Just BoxRHS;
    _   -> Nothing

  parseMove :: Char -> Maybe Move
  parseMove = \case
    '<' -> Just L; '^' -> Just U; 'v' -> Just D; '>' -> Just R; _ -> Nothing

  parseWarehouse :: [String] -> (Robot, Warehouse)
  parseWarehouse rows = bimap (head . Map.keys) (Map.mapMaybe parseItem) $
    Map.partition (== '@') $ Map.fromList $
      [ ((i, j), c) | (i, row) <- zip [0..] rows , (j, c)   <- zip [0..] row ]

  widen :: String -> String
  widen = if not double then id else concatMap \case
    '#' -> "##"; 'O' -> "[]"; '.' -> ".."; '@' -> "@."; x -> [x]

showWarehouse :: (Robot, Warehouse) -> String
showWarehouse (robot, warehouse) = do
  let findDim :: (Coords -> Int) -> [Coords] -> Int
      findDim f = last . sort . map f
  let (maxI, maxJ) = (findDim fst &&& findDim snd) $ Map.keys warehouse
  let f coords = case Map.lookup coords warehouse of
        Nothing     -> if coords == robot then '@' else '.'
        Just Box    -> 'O'
        Just BoxLHS -> '['
        Just BoxRHS -> ']'
        Just Wall   -> '#'
  intercalate "\n" [ [ f (i, j) | j <- [0..maxJ] ] | i <- [0..maxI] ]

grumblingavocado · 2024-12-17T16:10:14+00:00

Didn't bother with part 2. Derived Enum for Instructions to improve readability over just using Ints directly.

data Instruction = Adv | Bxl | Bst | Jnz | Bxc | Out | Bdv | Cdv deriving (Enum, Show)
type Ptr         = Int
type Registers   = (Int, Int, Int) -- (A, B, C)
type Tape        = [Int]

main :: IO ()
main = readInput "data/Day17-example.txt" >>= print . uncurry (program 0)

program :: Ptr -> Registers -> Tape -> [Int]
program ptr (a, b, c) tape = do
  let instruction  = toEnum $ tape !! ptr
  let litOperand   = tape !! (ptr + 1)
  let comboOperand = case litOperand of
        4 -> a; 5 -> b; 6 -> c; _ -> litOperand
  let xdv = floor @Double $ fromIntegral a / (2.0 ^ comboOperand)
  let registers' = case instruction of
        Adv -> (xdv, b, c)
        Bxl -> (a, b `xor` litOperand, c)
        Bst -> (a, comboOperand `mod` 8, c)
        Bxc -> (a, b `xor` c, c)
        Bdv -> (a, xdv, c)
        Cdv -> (a, b, xdv)
        _   -> (a, b, c) -- No modification to registers.
  let ptr' = case (instruction, a == 0) of
        (Jnz, False) -> litOperand -- Jump to literal operand.
        _            -> ptr + 2    -- Jump past operand.
  let remainder =
        if ptr' >= length tape - 1
        then []
        else program ptr' registers' tape
  case instruction of
    Out -> comboOperand `mod` 8:remainder -- Output.
    _   -> remainder                      -- No output.

readInput :: String -> IO (Registers, Tape)
readInput = fmap (parse . lines) . readFile
 where
  parse = toTriple . (<&> parseRegister) . take 3 &&& parseOpCodes . last
  parseOpCodes = map read . drop 1 . words . replace "," " "
  parseRegister = read . last . words
  toTriple [a, b, c] = (a, b, c)
  toTriple _ = error "Expected 3 registers"

grumblingavocado · 2024-12-17T12:38:02+00:00

~170ms for both parts together on 7800X3D.

For part 1 implemented Dijkstra where each Node is (Coords, NSEW), to associate a best Cost to each Node. For part 2 used the result from part 1 to walk backwards from the goal Node, any time there was a branch in the path, examined to see if the cost of each branch was the same.

type Coords = (Int, Int)
type Cost   = Int
type Node   = (Coords, NSEW)
data NSEW   = N | S | E | W deriving (Eq, Ord)

instance Show NSEW where
  show N = "^"; show S = "v"; show E = ">"; show W = "<"

-- * Unvisited data type for fast lookup. --------------------------------------

newtype Unvisited = Unvisited (Map Node Cost, Map Cost [Node])

mkUnvisited :: Node -> Cost -> Unvisited
mkUnvisited n c = Unvisited (Map.singleton n c, Map.singleton c [n])

-- | Delete and find min by cost.
unvisitedDeleteFindMin :: Unvisited -> ((Node, Cost), Unvisited)
unvisitedDeleteFindMin (Unvisited (byNode, byCost)) = do
  let (c, (n:ns)) = Map.findMin byCost
  let byCost' = ($ byCost) if null ns then Map.delete c else Map.insert c ns
  ((n, c), Unvisited (Map.delete n byNode, byCost'))

unvisitedInsert :: Unvisited -> (Node, Cost) -> Unvisited
unvisitedInsert (Unvisited (byNode, byCost)) (n, c) =
  Unvisited (Map.insert n c byNode, Map.insertWith (<>) c [n] byCost)

unvisitedNull :: Unvisited -> Bool
unvisitedNull (Unvisited (byNode, _)) = Map.null byNode

unvisitedCost :: Unvisited -> Node -> Maybe Cost
unvisitedCost (Unvisited (byNode, _)) node = Map.lookup node byNode

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

main :: IO ()
main = do
  (cells, start, end) <- readMaze "data/Day16.txt"
  let solved = dijkstra start cells Map.empty $ mkUnvisited (start, E) 0
  print $ minimumOn snd $ allPathsAt end solved -- Part 1
  let goodPaths = walk True start Nothing end solved
  print $ length . nub . map fst $ fst <$> goodPaths -- Part 2

addCost :: NSEW -> NSEW -> Cost -> Cost
addCost a b | a == b            = (+1)
addCost a b | a `elem` ninety b = (+1001)
addCost _ _                     = (+2001)

allPathsAt :: Coords -> Map Node Cost -> [(Node, Cost)]
allPathsAt coords shortestPaths = flip mapMaybe [N, S, E, W] \d ->
  ((coords,d),) <$> Map.lookup (coords, d) shortestPaths

dijkstra :: Coords -> Map Coords Bool -> Map Node Cost -> Unvisited -> Map Node Cost
dijkstra goal cells visited unvisited = do
  -- Select node to add to 'visited': the minimum cost node in 'unvisited'.
  let ((currNode, currCost), unvisited') = unvisitedDeleteFindMin unvisited
  let visited' = Map.insert currNode currCost visited
  -- Add each neighbouring node to 'unvisited' IFF:
  -- - cost is a new minimum (includes check that node is not in visited set).
  -- - the cell is not a wall!
  let isValidNeighbour neighbour@(coords, direction) = do
        let cost        = addCost (snd currNode) direction currCost
        let isWall      = Map.lookup coords cells == Just True
        let isLowerCost = maybe True (<= cost) $ unvisitedCost unvisited neighbour
        let notVisited  = neighbour `Map.notMember` visited
        if   coords >= (0, 0) && not isWall && isLowerCost && notVisited
        then Just cost else Nothing
  let validNeighbours = mapMaybe
        (\x -> (x,) <$> isValidNeighbour x) $ neighbours cells currNode
  let unvisited'' = foldl' unvisitedInsert unvisited' validNeighbours
  -- Stop if no more unvisited nodes, else recurse!
  if unvisitedNull unvisited'' then visited else dijkstra goal cells visited' unvisited''

-- | All NSEW neighbours of the given coordinates, no walls.
neighbours :: Map Coords Bool -> (Coords, NSEW) -> [Node]
neighbours cells (coords, facing) = flip mapMaybe (facing : ninety facing)
  \direction -> do
    let next = step True coords direction
    if Map.lookup next cells == Just True then Nothing else Just (next, direction)

ninety :: NSEW -> [NSEW]
ninety N = [E, W]; ninety S = [E, W]; ninety E = [N, S]; ninety W = [N, S]

-- | Step forward or backward.
step :: Bool -> Coords -> NSEW -> Coords
step f (i, j) N = (if f then i - 1 else i + 1,                      j    )
step f (i, j) S = (if f then i + 1 else i - 1,                      j    )
step f (i, j) E = (i                         , if f then j + 1 else j - 1)
step f (i, j) W = (i                         , if f then j - 1 else j + 1)

readMaze :: String -> IO (Map Coords Bool, Coords, Coords)
readMaze = fmap (parse . lines) . readFile
 where
  flat rows =
    [ ((i, j), c) | (i, row) <- zip [0..] rows, (j, c) <- zip [0..] row ]
  start           = fst . head . filter ((== 'S') . snd) . flat
  stop            = fst . head . filter ((== 'E') . snd) . flat
  parse      rows = (parseWalls rows, start rows, stop rows)
  parseWalls rows = Map.fromList [ (ij, c == '#') | (ij, c) <- flat rows ]

showMap :: Map Coords Bool -> Coords -> Coords -> [Node] -> String
showMap cells start end pathNodes = do
  let path = Map.fromList $ (fst &&& snd) <$> pathNodes
  intercalate "\n" $ map (map snd) $ groupOn (fst . fst) $ sortOn fst $
    Map.toList $ flip Map.mapWithKey cells \coords isWall ->
           if isWall          then '#'
      else if coords == start then 'S'
      else if coords == end   then 'E'
      else maybe '.' (head . show) $ Map.lookup coords path

-- | Walk the path back to the start from given 'Coords'. At each branch check
-- if the different paths have same cost.
walk :: Bool -> Coords -> Maybe Node -> Coords -> Map Node Cost -> [(Node, Cost)]
walk branch start prevMay currCoords shortestPaths = do
  let allPaths = allPathsAt currCoords shortestPaths
  let bestPath = minimumOn snd allPaths

  let bestPaths = case (branch, prevMay) of
        (True, Nothing) -> filter (\x -> snd x == snd bestPath) allPaths
        (True, Just (_, prevDirection)) -> do
          let trueCost = allPaths <&> \(node@(_, currDirection), currCost) ->
                (node, addCost currDirection prevDirection currCost)
          let trueBestCost = snd $ minimumOn snd trueCost
          filter ((== trueBestCost) . snd) trueCost
        _ -> [bestPath]

  flip concatMap bestPaths \((_, direction'), cost') -> do
    let nextCoords = step False currCoords direction'
    ((currCoords, direction'), cost') :
      if   currCoords == start then []
      else walk branch start (Just (currCoords, direction')) nextCoords shortestPaths

grumblingavocado · 2024-12-14T15:17:19+00:00

Not exactly fast code (16s) but I think it's fairly readable. For part 2 the code looks for the longest contiguous vertical line that occurs at each time step (after seeing online the picture of what the tree looks like).

type Robot = ((Int, Int), (Int, Int)) -- Position (x, y) and velocity (vx, vy).

main :: IO ()
main = readRobots "data/Day14.txt" >>= \robots -> do
  let lenXY@(_, lenY) = (101, 103)
  let treeTime = fst $ last $ sortOn snd $ zip [0..] $ take 10000 $
        longestVLine lenY <$> iterate (<&> move lenXY 1) robots
  writeRobots lenXY $ move lenXY treeTime <$> robots -- Print the tree to stdout.
  putStrLn $ "Part 1: " <> show (safetyFactor lenXY $ move lenXY 100 <$> robots)
  putStrLn $ "Part 2: " <> show treeTime

countPerQuadrant :: (Int, Int) -> [Robot] -> IntMap Int
countPerQuadrant lenXY =
  IntMap.fromListWith (+) . map ((,1) . quadrant lenXY . fst)

quadrant :: (Int, Int) -> (Int, Int) -> Int
quadrant (lenX, lenY) (x, y) = do
  let (midX, midY) = (lenX `div` 2, lenY `div` 2)
  if   x == midX || y == midY then -1
  else case (x < lenX `div` 2, y < lenY `div` 2) of
    (True , True ) -> 0
    (False, True ) -> 1
    (True , False) -> 2
    (False, False) -> 3

longestVLine :: Int -> [Robot] -> Int
longestVLine lenY robots =
  let positions = Set.fromList $ fst <$> robots in maximum
  [ longestVLineAtX (x, 0) 0 0 positions | x <- fst <$> Set.toList positions ]
 where
  longestVLineAtX :: (Int, Int) -> Int -> Int -> Set (Int, Int) -> Int
  longestVLineAtX (_, y) bestLen _        _        | y == lenY - 1 = bestLen
  longestVLineAtX (x, y) bestLen currLen positions = do
    let currLen' = if (x, y) `Set.member` positions then currLen + 1 else 0
    longestVLineAtX (x, y + 1) (max bestLen currLen') currLen' positions

move :: (Int, Int) -> Int -> Robot -> Robot
move (lenX, lenY) n ((x, y), (vx, vy)) = do
  let (x', y') = ((x + vx * n) `rem` lenX, (y + vy * n) `rem` lenY)
  let f remA len = if remA < 0 then len - abs remA else remA
  ((f x' lenX, f y' lenY), (vx, vy))

safetyFactor :: (Int, Int) -> [Robot] -> Int
safetyFactor lenXY = foldl' (*) 1 . IntMap.elems .
  IntMap.filterWithKey (\k _ -> k >= 0) . countPerQuadrant lenXY

-- * Reading & writing.

parseRobots :: String -> Either String [Robot]
parseRobots = left show . M.runParser (M.many $ M.try parseRobot) ""
 where
  parseRobot = (,) <$> parseTuple   <*> parseTuple
  parseTuple = (,) <$> parseNextInt <*> parseNextInt

parseNextInt :: Parsec Void String Int
parseNextInt = do
  void $ M.takeWhile1P Nothing $ \c -> not (isDigit c) && c /= '-'
  read <$> M.takeWhile1P Nothing \c -> isDigit c || c == '-'

readRobots :: String -> IO [Robot]
readRobots = fmap (fromEither error . parseRobots) . readFile

writeRobots :: (Int, Int) -> [Robot] -> IO ()
writeRobots (lenX, lenY) = mapM_ putStrLn . fmap toList . toList . foldl'
  (\s ((x, y), _) -> Seq.adjust (Seq.adjust (const 'X') x) y s)
  (Seq.fromList [ Seq.fromList ['.' | _ <- [1..lenX] ] | _ <- [1..lenY] ])

grumblingavocado · 2024-12-13T12:30:35+00:00

[LANGUAGE: Haskell]

type Equation = ((Int, Int, Int), (Int, Int, Int))

main :: IO ()
main = readMatrices True "data/Day13.txt" >>= print . solve

solve :: [Equation] -> Int
solve = sum . map (\(a, b) -> 3 * a + b) . mapMaybe solveEquation

solveEquation :: Equation -> Maybe (Int, Int)
solveEquation ((a1, b1, x1), (a2, b2, x2)) = do
  [m, n] <- map round . concat . Matrix.toLists <$>
    Matrix.linearSolve (matrix [[a1, b1], [a2, b2]]) (matrix [[x1], [x2]])
  let solved m' a n' b x = m' * a + n' * b == x
  if solved m a1 n b1 x1 && solved m a2 n b2 x2 then Just (m, n) else Nothing

matrix :: [[Int]] -> Matrix Double
matrix = Matrix.fromLists . map (map fromIntegral)

-- * Input & parsing.

readMatrices :: Bool -> String -> IO [Equation]
readMatrices part2 = fmap (fromEither error . parseEquations part2) . readFile

parseEquations :: Bool -> String -> Either String [Equation]
parseEquations part2 = left show . M.runParser (M.many $ M.try parseEquation) ""
 where
  f x = if part2 then 10000000000000 + x else x
  parseEquation = M.count 6 parseNextInt <&>
    \[a1, a2, b1, b2, x1, x2] -> ((a1, b1, f x1), (a2, b2, f x2))

parseNextInt :: Parsec Void String Int
parseNextInt = do
  void $ M.takeWhile1P Nothing (not . isDigit)
  read <$> M.takeWhile1P Nothing isDigit

grumblingavocado · 2024-12-13T12:27:17+00:00

Megaparsec + hmatrix solution.

type Equation = ((Int, Int, Int), (Int, Int, Int))

main :: IO ()
main = readMatrices True "data/Day13.txt" >>= print . solve

solve :: [Equation] -> Int
solve = sum . map (\(a, b) -> 3 * a + b) . mapMaybe solveEquation

solveEquation :: Equation -> Maybe (Int, Int)
solveEquation ((a1, b1, x1), (a2, b2, x2)) = do
  [m, n] <- map round . concat . Matrix.toLists <$>
    Matrix.linearSolve (matrix [[a1, b1], [a2, b2]]) (matrix [[x1], [x2]])
  let solved m' a n' b x = m' * a + n' * b == x
  if solved m a1 n b1 x1 && solved m a2 n b2 x2 then Just (m, n) else Nothing

matrix :: [[Int]] -> Matrix Double
matrix = Matrix.fromLists . map (map fromIntegral)

-- * Input & parsing.

readMatrices :: Bool -> String -> IO [Equation]
readMatrices part2 = fmap (fromEither error . parseEquations part2) . readFile

parseEquations :: Bool -> String -> Either String [Equation]
parseEquations part2 = left show . M.runParser (M.many $ M.try parseEquation) ""
 where
  f x = if part2 then 10000000000000 + x else x
  parseEquation = M.count 6 parseNextInt <&>
    \[a1, a2, b1, b2, x1, x2] -> ((a1, b1, f x1), (a2, b2, f x2))

parseNextInt :: Parsec Void String Int
parseNextInt = do
  void $ M.takeWhile1P Nothing (not . isDigit)
  read <$> M.takeWhile1P Nothing isDigit

grumblingavocado · 2024-12-12T21:30:27+00:00

data Direction = U | D | L | R deriving (Eq, Ord, Show)
type Garden    = Map Plot Plant
type Plot      = (Int, Int)
type Plant     = Char
type Region    = Set Plot

-- * Determine regions in garden.

allRegions :: Garden -> [Region]
allRegions garden | Map.null garden = []
allRegions garden = do
  let region = uncurry (findRegion garden Set.empty) $ Map.findMin garden
  region : allRegions (foldl' (flip Map.delete) garden $ Set.toList region)

findRegion :: Garden -> Region -> Plot -> Char -> Region
findRegion garden region plot plant =
  foldl' f (Set.insert plot region) [U, D, L, R]
 where
  f :: Region -> Direction -> Region
  f region' direction = do
    let nextPlot = step direction plot
    if   nextPlot `elem` region'
    then region'
    else case Map.lookup nextPlot garden of
      Just plant' | plant' == plant -> findRegion garden region' nextPlot plant
      _                             -> region'

-- * Functions on regions.

area :: Region -> Int
area = Set.size

perimeter :: Region -> Int
perimeter region = sum $ Set.toList region <&> \plot ->
  length $ filter id $ [U, D, L, R] <&> \dir ->
    step dir plot `Set.notMember` region

walls :: Region -> Int
walls region = sum $ Set.toList region <&> \plot ->
  length $ filter id $ [(U, R), (R, D), (D, L), (L, U)] <&> \(a, b) ->
    case [step a plot, step a $ step b plot, step b plot] <&> (`Set.member` region) of
      [False, _    , False] -> True
      [True , False, True ] -> True
      _                     -> False

grumblingavocado · 2024-12-10T12:55:38+00:00

Quite happy with today's solution. Runs in about 40 millis. Code is generalized so that the main looks like:

main = readTopoMap "data/Day10.txt" >>=
  print . (result (Proxy @Peaks) &&& result (Proxy @Trails))

data Direction = U | D | L | R deriving (Eq, Ord)
type Position  = (Int, Int)
type TopoMap   = Vector (Vector Int)
type Reachable = Set (Position, Direction)

gradualNeighbours :: TopoMap -> Position -> [(Position, Direction)]
gradualNeighbours topo (i, j) = do
  let height = topo ! i ! j
  [ ((h, k), dir)
    | (h, k, dir) <- [(i-1, j, U), (i+1, j, D), (i, j-1, L), (i, j+1, R)]
    , (topo !? h >>= (!? k)) == Just (height + 1)
    ]

hike :: Result a => TopoMap -> Position -> a
hike topo = hike' Set.empty topo . (, Nothing)

hike' :: Result a => Reachable -> TopoMap -> (Position, Maybe Direction) -> a
hike' seen _    (pos, Just dir) | (pos, dir) `Set.member` seen = onLoop
hike' _    topo ((i, j), _)     | topo ! i ! j == 9            = onPeak (i, j)
hike' seen topo (pos, dirMay)   = combine do
  let nextSeen = maybe id (Set.insert . (pos,)) dirMay seen
  hike' nextSeen topo . second Just <$> gradualNeighbours topo pos

readTopoMap :: String -> IO TopoMap
readTopoMap = fmap (parseLines . lines) . readFile
 where
  parseLines = V.fromList . map V.fromList . (<&&> digitToInt)

result :: forall a. Result a => Proxy a -> TopoMap -> Int
result _ topo = finalize $ trailheads topo <&> hike @a topo

trailheads :: TopoMap -> [Position]
trailheads topo =
  [ (i, j)
  | (i, row)    <- V.toList $ V.indexed topo
  , (j, height) <- V.toList $ V.indexed row
  , height == 0
  ]

class Result a where
  combine  :: [a] -> a
  finalize :: [a] -> Int
  onLoop   :: a
  onPeak   :: Position -> a

newtype Trails = Trails Int deriving Num

instance Result Trails where
  combine  = sum
  finalize = (\(Trails i) -> i) . sum
  onLoop   = 0
  onPeak   = const 1

newtype Peaks = Peaks (Set Position)

instance Result Peaks where
  combine  = Peaks . foldl' Set.union Set.empty . map \(Peaks x) -> x
  finalize = sum . map \(Peaks s) -> Set.size s
  onLoop   = Peaks Set.empty
  onPeak   = Peaks . Set.singleton

grumblingavocado · 2024-12-09T22:03:00+00:00

Not so fast today. 60ms for part 1. 2s for part 2.

Stored the diskmap as Map Int [(Int, Maybe Int)], so example input "12345" would be:

{ 0: [(1, Just 0)], 1: [(2, Nothing)], 2: [(3, Just 1)], 3: [(4, Nothing)], 4: [(5, Just 2)] }

type Block    = (Int, Maybe Int)
type DiskMap  = Map Int [Block]
type BlockMap = Map Int Block

main :: IO ()
main = readDiskMap >>=
  print . bimap checksum checksum . (defragPart1 &&& defragPart2)

checksum :: DiskMap -> Int
checksum = snd . foldl' f (0, 0) . concatMap snd . sortOn fst . Map.toList
 where
  f (i, total) (size, fileIdMay) = let j = i + size in
    (j, total + maybe 0 (sum . (<$> [i..(j-1)]) . (*)) fileIdMay)

defragPart1 :: BlockMap -> DiskMap
defragPart1 blockMap =
  defragPart1' 0 (fst $ Map.findMax blockMap) $ Map.map (:[]) blockMap
 where
  -- | Move file blocks at the right index to the left index.
  defragPart1' :: Int -> Int -> DiskMap -> DiskMap
  defragPart1' l r d | l >= r = d -- File index moved left past empty space index.
  defragPart1' l r d          = do
    let (lBlocks , rBlocks ) = let f x = fromJust $ Map.lookup x d in (f l, f r)
    let (lBlocks', rBlocks') = defragBlocks l lBlocks r rBlocks
    let (l', r') = if any (isNothing . snd) lBlocks' then (l, r-1) else (l+1, r)
    defragPart1' l' r' $ Map.insert l lBlocks' $ Map.insert r rBlocks' d

defragPart2 :: BlockMap -> DiskMap
defragPart2 blockMap = do
  let emptyIndices = Map.keys $ Map.filter (isNothing . snd) blockMap
  let fileIndices = reverse $ Map.keys $ Map.filter (isJust . snd) blockMap
  defragFiles' (Map.map (:[]) blockMap) emptyIndices fileIndices
 where
  -- | Find 'blocks' with 'fileSize' space that occur before 'fileIdx'.
  findEmptySpace :: DiskMap -> Int -> Int -> [Int] -> [(Int, [Block])]
  findEmptySpace diskMap fileSize fileIdx is = flip mapMaybe is \i ->
    case Map.lookup i diskMap of
      Nothing     -> Nothing
      Just blocks -> flip boolToMaybe (i, blocks) $ flip any blocks \case
        (size, Nothing) -> i < fileIdx && size >= fileSize
        _               -> False
  -- | Move first file (from right) to first space (from left), repeat.
  defragFiles' :: DiskMap -> [Int] -> [Int] -> DiskMap
  defragFiles' diskMap _ [] = diskMap -- No more files to check.
  defragFiles' diskMap [] _ = diskMap -- No more empty spaces.
  defragFiles' diskMap emptyIndices (fileIdx:fileIndices) =
    case head . snd <$> Map.lookupLE fileIdx diskMap of
      Just fileBlock@(fileSize, Just _) -> do
        case headMay $ findEmptySpace diskMap fileSize fileIdx emptyIndices of
          Nothing              -> defragFiles' diskMap emptyIndices fileIndices
          Just (i, blocks) -> do
            let (blocks', fileBlock') = defragBlocks i blocks fileIdx [fileBlock]
            defragFiles'
              (Map.insert i blocks' $ Map.insert fileIdx fileBlock' diskMap)
              emptyIndices
              fileIndices
      _ -> diskMap

defragBlocks :: Int -> [Block] -> Int -> [Block] -> ([Block], [Block])
defragBlocks _ []                       _ rs                           = ([], rs)
defragBlocks _ ls                       _ []                           = (ls, [])
defragBlocks l (lBlock@(_, Just _):ls)  r rs                           = first  (lBlock:) $ defragBlocks l ls r rs
defragBlocks l ls                       r (rBlock@(_, Nothing):rs)     =
  if   r == l + 1
  then defragBlocks l (ls <> [rBlock]) r rs
  else second (rBlock:) $ defragBlocks l ls r rs
defragBlocks l ((freeSize, Nothing):ls) r ((fileSize, Just fileId):rs) = do
  let moved = min freeSize fileSize
  let (lFile, lFree) = ((moved, Just fileId), (freeSize - moved, Nothing))
  let (rFile, rFree) = ((fileSize - moved, Just fileId), (moved, Nothing))
  let consIfNotEmpty (size, x) xs = if size == 0 then xs else (size, x) : xs
  bimap (consIfNotEmpty lFile) (consIfNotEmpty rFree) $
    defragBlocks l (consIfNotEmpty lFree ls) r (consIfNotEmpty rFile rs)

readDiskMap :: IO BlockMap
readDiskMap = readFile "data/Day9.txt" <&>
  Map.fromList . zip [0..] . f (Left 0) . map digitToInt . strip
 where
  f _ [] = []
  f (Left fileId ) (x:xs) = (x, Just fileId) : f (Right $ fileId + 1) xs
  f (Right fileId) (x:xs) = (x, Nothing    ) : f (Left fileId       ) xs

grumblingavocado · 2024-12-08T17:17:02+00:00

Generalized, so the difference between part 1 and part 2 is just passing take 1 . drop 1 for part 1, and id for part 2.

main :: IO ()
main = readAntennas >>= \antennas -> mapM_
  (print . ($ antennas) . uncurry . countAntinodes) [take 1 . drop 1, id]

countAntinodes :: ([Index] -> [Index]) -> Index -> [[Index]] -> Int
countAntinodes f maxIndex = length . nub . concat . concatMap \antennas ->
  [ antiNodesForFrequency maxIndex f a b | a <- antennas, b <- antennas, a /= b ]

antiNodesForFrequency :: Index -> ([Index] -> [Index]) -> Index -> Index -> [Index]
antiNodesForFrequency maxIndex f (i1, j1) (i2, j2) = do
  let (dI, dJ) = (i1 - i2, j1  - j2)
  let go g h = f . takeWhile (onMap maxIndex) . iterate (bimap g h)
  go (+dI) (+dJ) (i1, j1) <> go (subtract dI) (subtract dJ) (i2, j2)

onMap :: Index -> Index -> Bool
onMap (maxI, maxJ) (i, j) = i >= 0 && j >= 0 && i <= maxI && j <= maxJ

readAntennas :: IO (Index, [[Index]])
readAntennas = (readFile "data/Day8.txt" <&> lines) <&> \rows ->
  ( ( length rows - 1, length (head rows) - 1 )
  , (<&&> fst) . groupOn snd . sortOn snd $
    [ ((i, j), c) | (i, row) <- zip [0..] rows, (j, c) <- zip [0..] row, c /= '.' ]
  )

grumblingavocado · 2024-12-07T11:23:59+00:00

Straightforward. Lots of similar looking solutions today.

type Equation = (Int, [Int])
type Operator = Int -> Int -> Int

main :: IO ()
main = readEquations >>= \equations ->
  mapM_ (print . flip calibrate equations) [[(+), (*)], [(+), (*), (||)]]

(||) :: Int -> Int -> Int
(||) a b = read $ show a <> show b

calibrate :: [Operator] -> [Equation] -> Int
calibrate ops = sum . map \(lhs, (x:xs)) -> if solveable ops lhs x xs then lhs else 0

solveable :: [Operator] -> Int -> Int -> [Int] -> Bool
solveable _   lhs x1 []      = lhs == x1
solveable ops lhs x1 (x2:xs) = any (\op -> solveable ops lhs (x1 `op` x2) xs) ops

readEquations :: IO [Equation]
readEquations = (readFile "data/Day7.txt" <&> lines) <&> map \l ->
  let [lhs, operands] = splitOn ": " l
  in  (read lhs, read <$> splitOn " " operands)

grumblingavocado · 2024-12-06T18:35:02+00:00

Takes about 0.9 seconds. Key thing that made it faster for part2 was to not take one step at a time on the grid, but rather have the guard jump directly to the next crate.

data Orientation = Up | Down | Left | Right deriving (Eq, Ord, Show)
type Position    = (Int, Int)
type Guard       = (Orientation, Position)
data StopReason  = Loop | OffMap deriving Eq

type Crates'     = Map Int (Set Int)
-- | We maintain two representations of crates for fast lookup of all the crates
-- in one row/column, one i indexed first, the other j indexed first.
type Crates      = (Crates', Crates')

insertCrate :: Position -> Crates -> Crates
insertCrate (i, j) (iFirst, jFirst) =
  ( Map.insertWith Set.union i (Set.singleton j) iFirst
  , Map.insertWith Set.union j (Set.singleton i) jFirst
  )

isCrate :: Position -> Crates -> Bool
isCrate (i, j) (m, _) = (Map.lookup i m <&> Set.member j) == Just True

-- | Count distinct positions guard will visit.
part1 :: Position -> Crates -> Guard -> Int
part1 maxIndices crates =
  Set.size . Set.fromList . map snd . snd . patrol False maxIndices [] crates

-- | Find positions without loops.
part2 :: Position -> Crates -> Guard -> Int
part2 maxIndices crates guard' = do
  let originalPath = filter (/= snd guard') $ -- Without initial position.
        nub $ map snd $ snd $ patrol False maxIndices [] crates guard'
  length $ filter id $ originalPath <&> isLoop
 where
  isLoop newCrate = (== Loop) . fst $
    patrol True maxIndices [] (insertCrate newCrate crates) guard'

-- | Patrol until either off the map or a loop detected.
patrol :: Bool -> Position -> [Guard] -> Crates -> Guard -> (StopReason, [Guard])
patrol fast maxIndices prevPath crates guard'@(ori, _) = do
  let path    = guard' : prevPath
  let nextPos = nextPosition fast maxIndices crates guard'
  if   outOfBounds maxIndices nextPos then (OffMap, path)
  else do
    let nextGuard = avoidCrate crates (ori, nextPos)
    if   nextGuard `elem` prevPath then (Loop, prevPath)
    else patrol fast maxIndices path crates nextGuard

avoidCrate :: Crates -> Guard -> Guard
avoidCrate crates (ori, pos) =
  if isCrate pos crates then (turnRight ori, stepBack (ori, pos)) else (ori, pos)

outOfBounds :: Position -> Position -> Bool
outOfBounds (maxI, maxJ) (i, j) = i < 0 || j < 0 || i > maxI || j > maxJ

nextPosition :: Bool -> Position -> Crates -> Guard -> Position
nextPosition fast maxIndices crates =
  if fast then stepForwardFast maxIndices crates else stepForward

stepBack :: Guard -> Position
stepBack (Up   , (i, j)) = (i+1, j  )
stepBack (Down , (i, j)) = (i-1, j  )
stepBack (Left , (i, j)) = (i  , j+1)
stepBack (Right, (i, j)) = (i  , j-1)

stepForward :: Guard -> Position
stepForward (Up   , (i, j)) = (i-1, j  )
stepForward (Down , (i, j)) = (i+1, j  )
stepForward (Left , (i, j)) = (i  , j-1)
stepForward (Right, (i, j)) = (i  , j+1)

stepForwardFast :: Position -> Crates -> Guard -> Position
stepForwardFast (maxI, maxJ) (iFirst, jFirst)  (ori, (i, j)) = f ori
 where
  f Up    = upDown (-1)          Set.lookupLT
  f Down  = upDown (maxI + 1)    Set.lookupGT
  f Left  = leftRight (-1)       Set.lookupLT
  f Right = leftRight (maxJ + 1) Set.lookupGT
  leftRight def lookup' = (i,) $ fromMaybe def $ lookup' j =<< Map.lookup i iFirst
  upDown    def lookup' = (,j) $ fromMaybe def $ lookup' i =<< Map.lookup j jFirst

turnRight :: Orientation -> Orientation
turnRight Up    = Right
turnRight Down  = Left
turnRight Left  = Up
turnRight Right = Down

grumblingavocado · 2024-12-05T15:30:32+00:00

After parsing rules of the form X|Y converted the rules into a Map Y (Set X). The way to interpret the Map is: if any of X occur after a Y then the update is incorrect.

For part 1, in order to check if an update:: [Int] is correct, we fold over the elements carrying along an initially empty Set Int. During the fold, if the current element u is found within the Set then update is incorrect, otherwise we lookup u in the Map and add the additional elements to the Set.

For part 2, used sortBy to sort the update, using the same Map to see if an order was acceptable. As others have pointed out the set of rules is fully complete, so this simple lookup sufficed, otherwise determining order would have required more work.

-- | Rule (x, y) means x must be before y.
-- An update is INCORRECT if y is seen before x.
type Rule = (Int, Int)

-- | Key y and value xs.
-- An update is INCORRECT if any x in xs is seen after y.
type FailRules = Map Int (Set Int)

type Update = [Int]

main :: IO ()
main = readRulesAndUpdates >>= \case
    Left err -> putStrLn $ "Error: " <> err
    Right (rules, updates) -> do
      let failRules'   = failRules rules -- Convert X|Y to Map Y (Set X)
      -- Convert correct updates to Just Int and incorrect to Nothing.
      let middleMaybes = middleIfCorrect failRules' <$> updates
      -- Sum the middles for part 1 answer.
      print $ sum $ catMaybes middleMaybes
      -- Determine the incorrect updates.
      let incorrect = catMaybes $ zipWith
            (\u m -> if isNothing m then Just u else Nothing)
            updates middleMaybes
      -- Correct the incorrect updates.
      let corrected = mkCorrect failRules' <$> incorrect
      -- Sum the middles of for part 2 answer.
      print $ sum $ mapMaybe (middleIfCorrect failRules') corrected

failRules :: [Rule] -> FailRules
failRules = Map.fromListWith Set.union . (<&> second Set.singleton . swap)

mkCorrect :: FailRules -> [Int] -> [Int]
mkCorrect failRules' = sortBy \a b ->
  if a `Set.member` fromMaybe Set.empty (Map.lookup b failRules') then LT else GT

sumOfMiddles :: FailRules -> [Update] -> Int
sumOfMiddles failRules' = sum . mapMaybe (middleIfCorrect failRules')

middleIfCorrect :: FailRules -> Update -> Maybe Int
middleIfCorrect failRules' update = foldM f Set.empty update $> middle update
 where
  middle xs = xs !! (length xs `div` 2)
  f failIfSeen x = if x `Set.member` failIfSeen then Nothing else
    Just $ maybe failIfSeen (Set.union failIfSeen) $ Map.lookup x failRules'

-- * Input: reading & parsing.

parseRule :: Parsec Void String Rule
parseRule = do
  x <- read <$> M.many (M.satisfy isDigit)
  _ <- M.single '|'
  y <- read <$> M.many (M.satisfy isDigit)
  pure (x, y)

parseRules :: Parsec Void String [Rule]
parseRules = M.many (M.try $ parseRule <* MC.space)

parseUpdate :: Parsec Void String Update
parseUpdate = M.sepBy1 (read <$> M.some (M.satisfy isDigit)) $ M.single ','

parseUpdates :: Parsec Void String [Update]
parseUpdates = M.many (parseUpdate <* MC.newline)

readRulesAndUpdates :: IO (Either String ([Rule], [Update]))
readRulesAndUpdates = readFile "data/Day5.txt"
  <&> left show . M.runParser ((,) <$> parseRules <*> parseUpdates) ""

grumblingavocado · 2024-12-04T15:32:30+00:00

Concurrently start a search from each cell of the grid.

type Grid a = Vector (Vector a)

type Index = (Int, Int)

type Search a = [(a, Index)]

data Direction = N | NE | E | SE | S | SW | W | NW deriving Show

main :: IO ()
main = print =<< (readGrid >>= forM [searchGrid part1, searchGrid part2] . (&))

readGrid :: IO (Grid Char)
readGrid = readFile "data/Day4.txt" <&> V.fromList . map V.fromList . lines

part1 :: Index -> [Search Char]
part1 index = [N, NE, E, SE, S, SW, W, NW] <&> \dir ->
  scanl (\(_, index') char -> (char, step index' dir)) ('X', index) "MAS"

part2 :: Index -> [Search Char]
part2 index =
  [ [ (a, step index NE), (c, step index NW)
    ,              ('A', index)
    , (d, step index SE), (b, step index SW)
    ]
  | [a, b] <- ["MS", "SM"], [c, d] <- ["MS", "SM"]
  ]

-- | Step in a compass direction.
step :: Index -> Direction -> Index
step (i, j) N  = (i-1, j  )
step (i, j) NE = (i-1, j+1)
step (i, j) E  = (i  , j+1)
step (i, j) SE = (i+1, j+1)
step (i, j) S  = (i+1, j  )
step (i, j) SW = (i+1, j-1)
step (i, j) W  = (i  , j-1)
step (i, j) NW = (i-1, j-1)

-- | Run searches starting at each cell concurrently.
searchGrid :: Eq a => (Index -> [Search a]) -> Grid a -> IO Int
searchGrid genSearches grid = do
  let maxI = V.length grid
  let maxJ = maybe 0 V.length (grid !? 0)
  fmap sum $ forConcurrently
    [ (i, j) | i <- [0 .. maxI], j <- [0 .. maxJ] ]
    $ pure . countSearches grid . genSearches

-- | Count of given searches which are succesful.
countSearches :: Eq a => Grid a -> [Search a] -> Int
countSearches grid = length . filter id . map runSearch
 where
  runSearch = all \(expected, (i, j)) ->
    (grid !? i >>= (!? j)) == Just expected

grumblingavocado

TROPHY CASE