Advent of Code 2023 first 3 days

Day1.hs

module Year2023.Day1 (
    parts,
) where

import Adlude
import Data.Char (isDigit)
import Data.List (tails)
import qualified Data.Text as T

numbers =
    [ ("one", 1)
    , ("two", 2)
    , ("three", 3)
    , ("four", 4)
    , ("five", 5)
    , ("six", 6)
    , ("seven", 7)
    , ("eight", 8)
    , ("nine", 9)
    , ("1", 1)
    , ("2", 2)
    , ("3", 3)
    , ("4", 4)
    , ("5", 5)
    , ("6", 6)
    , ("7", 7)
    , ("8", 8)
    , ("9", 9)
    ]

findDigits line =
    let
        matches = fmap snd $ mapMaybe (\sub -> find ((`T.isPrefixOf` sub) . fst) numbers) $ T.tails line
     in
        head matches * 10 + last matches

parts :: IO (Int, Int)
parts = do
    let solve = sum . fmap parsePart1
    lines <-
        T.splitOn "\n" . T.strip . T.pack
            <$> readFile
                "src/Year2023/1.txt"
    pure (solve lines, sum $ findDigits <$> lines)
  where
    parsePart1 line =
        let
            nums = T.filter isDigit line
         in
            read [T.head nums, T.last nums]

Day2.hs

{-# LANGUAGE TypeApplications #-}

module Year2023.Day2 (
    parts,
) where

import Adlude
import qualified Data.Map.Strict as M
import qualified Data.Text as T

parts :: IO (Int, Int)
parts = do
    lines <-
        fmap parseLine . T.splitOn "\n" . T.strip . T.pack
            <$> readFile
                "src/Year2023/2.txt"
    pure
        ( sum $ mapMaybe parsePossible lines
        , sum $ product . M.elems . M.unionsWith max . gameToMap <$> lines
        )
  where
    splitReadFirst sep terms =
        case T.splitOn sep terms of
            [n, vs] -> (read @Int $ T.unpack n, vs)
    gameToMap (game, turns) = M.fromList . fmap swap <$> turns
    parseLine line =
        let
            (game, rawTurns) = splitReadFirst ": " $ T.drop 5 line
            turns = fmap (splitReadFirst " ") . T.splitOn ", " <$> T.splitOn "; " rawTurns
         in
            (game, turns)

    parsePossible (game, turns) =
        game <$ guard (all (all validPull) turns)

    validPull (amount, color) =
        bagContains color >= amount

    bagContains = \case
        "red" -> 12
        "green" -> 13
        "blue" -> 14

Day3.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE NamedFieldPuns #-}

module Year2023.Day3 (
    parts,
) where

import Adlude
import Control.Applicative hiding (empty, many, some)
import Control.Monad (void)
import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Void (Void)
import GHC.Generics (Generic)
import Text.Megaparsec hiding (empty)
import Text.Megaparsec.Char.Lexer (decimal, lexeme)
import Text.Megaparsec.Pos

around :: Location -> [Location]
around Location{x, y} =
    uncurry Location <$> adjacent2dPoints (x, y)

data Location = Location {x :: Int, y :: Int}
    deriving (Show, Eq)

symbolsContains symbols pos =
    any (\n -> any ((== n) . snd) symbols) neighbors
  where
    neighbors = occupies pos >>= around

data Input = Input
    { numbers :: [(Int, Location)]
    , symbols :: [(Char, Location)]
    }
    deriving stock (Show, Generic)
    deriving (Monoid, Semigroup) via (GenericSemigroupMonoid Input)

gearRatio numbers ('*', location) =
    case filter (symbolsContains [('*', location)]) numbers of
        [(n1, _), (n2, _)] -> Just $ n1 * n2
        _ -> Nothing
gearRatio _ _ = Nothing

type Parser = Parsec Void T.Text

occupies :: (Int, Location) -> [Location]
occupies (num, Location{x, y}) = fmap (\(x0, _) -> Location{x = x + x0, y}) $ zip [0 ..] $ show num

input :: Parser Input
input = mconcat <$> many (number <|> nonEmpty) <* eof

number :: Parser Input
number = do
    pos <- getSourcePos
    number <- lexeme' decimal
    pure $ mempty{numbers = [(number, locationFromPos pos)]}

nonEmpty :: Parser Input
nonEmpty = do
    pos <- getSourcePos
    sym <- lexeme' $ satisfy $ const True
    pure $ mempty{symbols = [(sym, locationFromPos pos)]}

locationFromPos pos =
    Location{x = unPos $ sourceColumn pos, y = unPos $ sourceLine pos}

lexeme' :: Parser a -> Parser a
lexeme' = lexeme empty

empty :: Parser ()
empty = void $ many $ single '.' <|> single '\n'

parts :: IO (Int, Int)
parts = do
    let fileName = "src/Year2023/3.txt"
    raw <- TIO.readFile fileName
    let result = parse input fileName raw
    case result of
        Left err -> do
            putStrLn $ errorBundlePretty err
            pure (1, 1)
        Right Input{numbers, symbols} ->
            pure (sum $ fst <$> filter (symbolsContains symbols) numbers, sum $ mapMaybe (gearRatio numbers) symbols)