chore: complete day 5

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

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
+

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,

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

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

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