diff --git a/haskell/Main.hs b/haskell/Main.hs index 2e181ac..2260f1b 100644 --- a/haskell/Main.hs +++ b/haskell/Main.hs @@ -1,22 +1,16 @@ module Main (main) where -import Control.Monad -import Control.Monad.State -import Data.Bifunctor import Data.ByteString.Lazy qualified as BL import Data.Functor -import Data.Maybe -import Data.Text (Text) -import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Text.IO qualified as T -import Data.Void +import Puzzle +import Puzzles.Day1 +import Puzzles.Day2 import Test.Tasty import Test.Tasty.Golden (goldenVsString) import Test.Tasty.Ingredients.ConsoleReporter import Text.Megaparsec hiding (Pos) -import Text.Megaparsec.Char -import Text.Megaparsec.Char.Lexer qualified as Lex main :: IO () main = @@ -41,87 +35,3 @@ main = zip (map show [1 :: Int ..]) parts <&> \(n, pp) -> goldenVsString n ("../outputs/" <> t <> "/" <> pt <> "/" <> n) $ BL.fromStrict . encodeUtf8 . pp <$> input - -data Puzzle = forall input. Puzzle - { number :: Word - , parser :: Parsec Void Text input - , parts :: [input -> Text] - } - -puzzle1 :: Puzzle -puzzle1 = - Puzzle - { number = 1 - , parser = flip sepEndBy newline $ (,) <$> ((char 'L' $> L) <|> (char 'R' $> R)) <*> (Inc <$> Lex.decimal) - , parts = - [ T.show - . sum - . flip evalState 50 - . traverse \(d, i) -> state \p -> - let (_, p') = step i d p - in (Count if p' == 0 then 1 else 0, p') - , T.show - . sum - . flip evalState 50 - . traverse \(d, i) -> state \p -> - let (c, p') = step i d p - c' = case d of - R -> abs c - L -> - if - | p == 0 -> abs c - 1 - | p' == 0 -> abs c + 1 - | otherwise -> abs c - in (c', p') - ] - } - -data Direction = L | R - deriving (Eq, Ord, Show) - -newtype Pos = Pos Int - deriving newtype (Eq, Ord, Show, Num) - -newtype Inc = Inc Int - deriving newtype (Eq, Ord, Show, Num) - -newtype Count = Count Int - deriving newtype (Eq, Ord, Show, Num) - -step :: Inc -> Direction -> Pos -> (Count, Pos) -step (Inc i) d (Pos p) = bimap Count Pos case d of - L -> (p - i) `divMod` 100 - R -> (p + i) `divMod` 100 - -puzzle2 :: Puzzle -puzzle2 = - Puzzle - { number = 2 - , parser = (<* newline) $ flip sepBy (char ',') $ (,) <$> (Lex.decimal <* char '-') <*> Lex.decimal - , parts = - [ T.show - . sum - . concatMap - (mapMaybe (\n -> guard (isRepetition2 n) $> n) . uncurry enumFromTo) - , T.show - . sum - . concatMap - (mapMaybe (\n -> guard (isRepetitionN n) $> n) . uncurry enumFromTo) - ] - } - -newtype ID = ID Int - deriving newtype (Eq, Ord, Show, Num, Enum) - -isRepetition2 :: ID -> Bool -isRepetition2 (T.show -> n) = case T.length n `divMod` 2 of - (d, 0) -> equalChunks n d - _ -> False - -isRepetitionN :: ID -> Bool -isRepetitionN (T.show -> n) = flip any [1 .. T.length n `div` 2] $ equalChunks n - -equalChunks :: Text -> Int -> Bool -equalChunks n i = case T.chunksOf i n of - [] -> True - x : xs -> all (== x) xs diff --git a/haskell/Puzzle.hs b/haskell/Puzzle.hs new file mode 100644 index 0000000..b137bfe --- /dev/null +++ b/haskell/Puzzle.hs @@ -0,0 +1,11 @@ +module Puzzle where + +import Data.Text (Text) +import Data.Void +import Text.Megaparsec + +data Puzzle = forall input. Puzzle + { number :: Word + , parser :: Parsec Void Text input + , parts :: [input -> Text] + } diff --git a/haskell/Puzzles/Day1.hs b/haskell/Puzzles/Day1.hs new file mode 100644 index 0000000..ca1829d --- /dev/null +++ b/haskell/Puzzles/Day1.hs @@ -0,0 +1,55 @@ +module Puzzles.Day1 (puzzle1) where + +import Control.Monad.State +import Data.Bifunctor +import Data.Functor +import Data.Text qualified as T +import Puzzle +import Text.Megaparsec hiding (Pos) +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as Lex + +puzzle1 :: Puzzle +puzzle1 = + Puzzle + { number = 1 + , parser = flip sepEndBy newline $ (,) <$> ((char 'L' $> L) <|> (char 'R' $> R)) <*> (Inc <$> Lex.decimal) + , parts = + [ T.show + . sum + . flip evalState 50 + . traverse \(d, i) -> state \p -> + let (_, p') = step i d p + in (Count if p' == 0 then 1 else 0, p') + , T.show + . sum + . flip evalState 50 + . traverse \(d, i) -> state \p -> + let (c, p') = step i d p + c' = case d of + R -> abs c + L -> + if + | p == 0 -> abs c - 1 + | p' == 0 -> abs c + 1 + | otherwise -> abs c + in (c', p') + ] + } + +data Direction = L | R + deriving (Eq, Ord, Show) + +newtype Pos = Pos Int + deriving newtype (Eq, Ord, Show, Num) + +newtype Inc = Inc Int + deriving newtype (Eq, Ord, Show, Num) + +newtype Count = Count Int + deriving newtype (Eq, Ord, Show, Num) + +step :: Inc -> Direction -> Pos -> (Count, Pos) +step (Inc i) d (Pos p) = bimap Count Pos case d of + L -> (p - i) `divMod` 100 + R -> (p + i) `divMod` 100 diff --git a/haskell/Puzzles/Day2.hs b/haskell/Puzzles/Day2.hs new file mode 100644 index 0000000..33e3351 --- /dev/null +++ b/haskell/Puzzles/Day2.hs @@ -0,0 +1,44 @@ +module Puzzles.Day2 (puzzle2) where + +import Control.Monad +import Data.Functor +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as T +import Puzzle +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as Lex + +puzzle2 :: Puzzle +puzzle2 = + Puzzle + { number = 2 + , parser = (<* newline) $ flip sepBy (char ',') $ (,) <$> (Lex.decimal <* char '-') <*> Lex.decimal + , parts = + [ T.show + . sum + . concatMap + (mapMaybe (\n -> guard (isRepetition2 n) $> n) . uncurry enumFromTo) + , T.show + . sum + . concatMap + (mapMaybe (\n -> guard (isRepetitionN n) $> n) . uncurry enumFromTo) + ] + } + +newtype ID = ID Int + deriving newtype (Eq, Ord, Show, Num, Enum) + +isRepetition2 :: ID -> Bool +isRepetition2 (T.show -> n) = case T.length n `divMod` 2 of + (d, 0) -> equalChunks n d + _ -> False + +isRepetitionN :: ID -> Bool +isRepetitionN (T.show -> n) = flip any [1 .. T.length n `div` 2] $ equalChunks n + +equalChunks :: Text -> Int -> Bool +equalChunks n i = case T.chunksOf i n of + [] -> True + x : xs -> all (== x) xs diff --git a/haskell/aoc.cabal b/haskell/aoc.cabal index 0662b60..9b3f18e 100644 --- a/haskell/aoc.cabal +++ b/haskell/aoc.cabal @@ -8,6 +8,10 @@ maintainer: georgefsthomas@gmail.com executable aoc main-is: Main.hs hs-source-dirs: . + other-modules: + Puzzle + Puzzles.Day1 + Puzzles.Day2 default-language: GHC2024 default-extensions: BlockArguments