wip: 2022 day 5

2022/README.md

@@ -3,7 +3,7 @@
 |  S  |  M  |  T  |  W  |  T  |  F  |  S   |
 | :-: | :-: | :-: | :-: | :-: | :-: | :--: |
 |     |     |     |     | [1] | [2] |  [3] |
-| [4] |  5  |  6  |  7  |  8  |  9  |  10  |
+| [4] | [5] |  6  |  7  |  8  |  9  |  10  |
 | 11  | 12  | 13  | 14  | 15  | 16  |  17  |
 | 18  | 19  | 20  | 21  | 22  | 23  |  24  |
 | 24  |     |     |     |     |     |      |
@@ -12,3 +12,4 @@
 [2]: ./src/Aoc/Day2.hs
 [3]: ./src/Aoc/Day3.hs
 [4]: ./src/Aoc/Day4.hs
+[5]: ./src/Aoc/Day5.hs

2022/aoc.cabal

@@ -30,6 +30,7 @@ library
       Aoc.Day2
       Aoc.Day3
       Aoc.Day4
+      Aoc.Day5
   other-modules:
       Paths_aoc
   hs-source-dirs:

2022/app/Main.hs

@@ -6,6 +6,7 @@ import qualified Aoc.Day1
 import qualified Aoc.Day2
 import qualified Aoc.Day3
 import qualified Aoc.Day4
+import qualified Aoc.Day5
 
 main :: IO ()
 main = do
@@ -19,6 +20,7 @@ main = do
                       2 -> Aoc.Day2.solve
                       3 -> Aoc.Day3.solve
                       4 -> Aoc.Day4.solve
+                      5 -> Aoc.Day5.solve
                       _ -> error "unknown day"
 
   putStrLn $ f part contents

2022/src/Aoc/Day5.hs

@@ -0,0 +1,77 @@
+module Aoc.Day5 (solve) where
+
+import Aoc (runReadP)
+import Data.Char (isDigit)
+import Data.Maybe
+import Data.List (transpose)
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+import Text.ParserCombinators.ReadP
+
+data Crate = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
+  deriving (Read, Show)
+type Stack = [Crate]
+type State = IntMap Stack
+
+data Move = Move { amount :: Int, from :: Int, to :: Int }
+  deriving (Show)
+type Procedure = [Move]
+
+data Input = Input { state :: State, procedure :: Procedure }
+  deriving (Show)
+
+parseMove :: String -> Move
+parseMove = runReadP moveP
+  where
+    intP :: ReadP Int
+    intP = do
+      digits <- munch1 isDigit
+      return $ read digits
+
+    moveP :: ReadP Move
+    moveP = do
+      _ <- string "move "
+      amount' <- intP
+      _ <- string " from "
+      from' <- intP
+      _ <- string " to "
+      to' <- intP
+      return $ Move { amount = amount', from = from', to = to' }
+
+parseInput :: String -> Input
+parseInput input = Input { state = state, procedure = procedure }
+  where
+    -- i hate this
+    stateContents = concat $ transpose $ takeWhile (/= "") $ lines input
+    parseState "" _ state = IntMap.map reverse state
+    parseState (x:xs) acc state
+      | x == '[' || x == ']' || x == ' ' = parseState xs acc state
+      | isDigit x                        = parseState xs [] $ IntMap.insert (read [x]) acc state
+      | otherwise                        = parseState xs ((read [x]):acc) state
+    state = parseState stateContents [] IntMap.empty
+
+    procedureContents = drop 1 $ dropWhile (/= "") $ lines input
+    procedure = map parseMove procedureContents
+
+doMove :: Move -> State -> State
+doMove m s = s'
+  where
+    (forTo, backToFrom) = splitAt (amount m) $ fromJust $ IntMap.lookup (from m) s
+    addToTo to' = Just $ (reverse forTo) ++ to'
+    s' = IntMap.update addToTo (to m) $ IntMap.insert (from m) backToFrom s
+
+stackLabel :: Stack -> String
+stackLabel [] = ""
+stackLabel (x:_) = show x
+
+message :: State -> String
+message s = concat $ map stackLabel $ IntMap.elems s
+
+solve :: Integer -> String -> String
+solve 1 input = message $ foldr doMove state' procedure'
+  where
+    input' = parseInput input
+    state' = state input'
+    procedure' = procedure input'
+
+solve _ _ = "?"