From 9012b7b1254f245028e494622bdcd1b44c30a48f Mon Sep 17 00:00:00 2001 From: sgoudham Date: Tue, 6 Dec 2022 04:08:45 +0000 Subject: [PATCH] chore: complete day 5 --- advent-of-haskell.cabal | 1 + aoc/AOC.hs | 15 ++++++++++- aoc/AOC/Types.hs | 4 ++- runner/Main.hs | 6 ++--- runner/Tests.hs | 15 ++++++----- solutions/Days/Day05.hs | 60 ++++++++++++++++++++++++++++++++++++----- 6 files changed, 82 insertions(+), 19 deletions(-) diff --git a/advent-of-haskell.cabal b/advent-of-haskell.cabal index 029f68d..5ee1c86 100644 --- a/advent-of-haskell.cabal +++ b/advent-of-haskell.cabal @@ -91,5 +91,6 @@ library solutions , base ^>=4.16.3.0 , containers ^>=0.6.5 , text ^>=2.0 + , split ^>=0.2.3 hs-source-dirs: solutions diff --git a/aoc/AOC.hs b/aoc/AOC.hs index f606666..9843fa5 100644 --- a/aoc/AOC.hs +++ b/aoc/AOC.hs @@ -1,7 +1,20 @@ +{-# language ScopedTypeVariables, GADTs #-} + module AOC ( module AOC.Types, - mkAocClient + mkAocClient, + showSolution, ) where import AOC.Types import AOC.API +import Type.Reflection + +-- TODO find a better way to avoid 'show'ing Stringlike things in +-- quotes ("") without resorting to end-users having to wrap Solutions +-- with something like data StringOr = StringLike a | NotStringLike b +showSolution :: forall a. (Typeable a, Show a) => a -> String +showSolution a = case eqTypeRep (typeRep @a) (typeRep @String) of + Just HRefl -> a + Nothing -> show a + diff --git a/aoc/AOC/Types.hs b/aoc/AOC/Types.hs index 1ea2ba0..8e1a011 100644 --- a/aoc/AOC/Types.hs +++ b/aoc/AOC/Types.hs @@ -7,9 +7,11 @@ module AOC.Types ( import Data.Text (Text) import GHC.Generics (Generic) import Web.Internal.FormUrlEncoded (ToForm) +import Type.Reflection data Solution where - Solution :: Show b => (Text -> a) -> (a -> b) -> (a -> b) -> Solution + Solution :: (Typeable b, Show b) => + (Text -> a) -> (a -> b) -> (a -> b) -> Solution data Submission = Submission { part :: Int, diff --git a/runner/Main.hs b/runner/Main.hs index 0d28de7..38e967b 100644 --- a/runner/Main.hs +++ b/runner/Main.hs @@ -1,6 +1,6 @@ module Main where -import AOC (Solution (..), mkAocClient) +import AOC (Solution (..), mkAocClient, showSolution) import Configuration.Dotenv (defaultConfig, loadFile) import Control.Exception (IOException, catch) import Control.Monad (when) @@ -71,8 +71,8 @@ run (Solution pInput part1 part2) part input = Just n -> printf "Part %d: %s\n" n $ if n == 1 then part1' else part2' where parsed = pInput input - part1' = show $ part1 parsed - part2' = show $ part2 parsed + part1' = showSolution $ part1 parsed + part2' = showSolution $ part2 parsed -- | CLI parser opts :: ParserInfo Options diff --git a/runner/Tests.hs b/runner/Tests.hs index fc269d6..62eb517 100644 --- a/runner/Tests.hs +++ b/runner/Tests.hs @@ -2,7 +2,7 @@ module Tests (test) where -import AOC (Solution (..)) +import AOC (Solution (..), showSolution) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Void (Void) @@ -14,6 +14,7 @@ import Test.Tasty.Ingredients.Basic (consoleTestReporter) import Text.Megaparsec import Text.Megaparsec.Char (newline, space) import Text.Megaparsec.Char.Lexer qualified as L +import Type.Reflection data TestInput = TestInput { _testName :: T.Text, @@ -55,23 +56,23 @@ test (Solution pInput part1 part2) day part = do -- | Given an input parser, part1 or part2 function, and a test input, -- generate an HUnit test. -mkTest :: Show b => (T.Text -> a) -> (a -> b) -> TestInput -> TestTree +-- TODO this feels like a leaky abstraction of Solution +mkTest :: (Typeable b, Show b) => (T.Text -> a) -> (a -> b) -> TestInput -> TestTree mkTest pInput part TestInput {..} = testCase (T.unpack _testName) $ T.unpack _testExpected @=? result where - result = show . part $ pInput _testInput + result = showSolution . part $ pInput _testInput -- | Parse test files into TestInput's +-- TODO more robust parsing and better, user-friendly custom errors pTests :: Parser [TestInput] pTests = many pTest <* eof where pTest = TestInput <$> pName <*> pInput <*> pExpected "Test" - pName = T.pack <$> (symbol "-" *> lexeme (some (anySingleBut '\n'))) "Test Name" + -- TODO handle leading space in test input more elegantly + pName = T.pack <$> (symbol "-" *> some (anySingleBut '\n') <* newline) "Test Name" pInput = T.pack <$> someTill anySingle (symbol "==") "Input Lines" pExpected = T.pack <$> many (anySingleBut '\n') <* newline "Expected Output" -lexeme :: Parser a -> Parser a -lexeme = L.lexeme space - symbol :: T.Text -> Parser T.Text symbol = L.symbol space diff --git a/solutions/Days/Day05.hs b/solutions/Days/Day05.hs index 85af2ec..3a4d6c3 100644 --- a/solutions/Days/Day05.hs +++ b/solutions/Days/Day05.hs @@ -1,16 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + module Days.Day05 (day05) where import AOC (Solution (..)) -import qualified Data.Text as T +import Data.Char +import Data.List qualified as L +import Data.List.Split qualified as S +import Data.Text qualified as T + +-- 1. How many crates to move +-- 2. The stack to move crates from +-- 3. The stack to move crates to +type Instruction = (Int, Int, Int) + +mapTuple :: (a -> b) -> (a, a, a) -> (b, b, b) +mapTuple f (a1, a2, a3) = (f a1, f a2, f a3) + +replaceNth :: Int -> a -> [a] -> [a] +replaceNth _ _ [] = [] +replaceNth n newVal (x : xs) + | n == 0 = newVal : xs + | otherwise = x : replaceNth (n - 1) newVal xs day05 :: Solution day05 = Solution parseInput part1 part2 -parseInput :: T.Text -> a -parseInput = error "parseInput not defined for day 05" +parseInput :: T.Text -> ([String], [Instruction]) +parseInput input = (cleanStacks, intInsts) + where + [crates, insts] = S.splitOn "\n\n" (T.unpack input) + inst = filter (not . null) $ map (filter isDigit) (words insts) + intInsts = map (\[one, two, three] -> mapTuple read (one, two, three)) (S.chunksOf 3 inst) + stacks = init $ lines crates + cleanStacks = map concat $ L.transpose $ map (map filtered . S.chunksOf 4) stacks + filtered xs = [xs !! 1 | xs !! 1 /= ' '] -part1 :: a -> Int -part1 = error "part1 not defined for day 05" +part1 :: ([String], [Instruction]) -> String +part1 (stacks, instructions) = map head (foldl logic stacks instructions) + where + logic :: [String] -> Instruction -> [String] + logic stacks' (num, from, to) = replacedStacks + where + to' = to - 1 + from' = from - 1 + sFrom = stacks' !! from' + sTo = stacks' !! to' + taken = replaceNth from' (drop num sFrom) stacks' + replacedStacks = replaceNth to' (reverse (take num sFrom) ++ sTo) taken -part2 :: a -> Int -part2 = error "part2 not defined for day 05" +part2 :: ([String], [Instruction]) -> String +part2 (stacks, instructions) = map head (foldl logic stacks instructions) + where + logic :: [String] -> Instruction -> [String] + logic stacks' (num, from, to) = replacedStacks + where + to' = to - 1 + from' = from - 1 + sFrom = stacks' !! from' + sTo = stacks' !! to' + taken = replaceNth from' (drop num sFrom) stacks' + replacedStacks = replaceNth to' (take num sFrom ++ sTo) taken