Day 5 Part 2

aoc2022.cabal

@@ -41,6 +41,8 @@ library
       Day4.Shared
       Day5
       Day5.Part1
+      Day5.Part2
+      Day5.Shared
       Lib
   other-modules:
       Paths_aoc2022

src/Day5.hs

@@ -1,6 +1,7 @@
 module Day5 (day5) where
 
 import Day5.Part1
+import Day5.Part2
 
 
 day5 :: IO ()
@@ -9,3 +10,5 @@ day5 = do
    putStrLn "Day5"
    let message = day5_1 input
    putStrLn ("Message from crates: " ++ message)
+   let secondMessage = day5_2 input
+   putStrLn ("Actuale message from crates: " ++ secondMessage)

src/Day5/Part1.hs

@@ -1,82 +1,11 @@
 module Day5.Part1 (
-  StackIndex (..),
-  Operation (..),
-  Stack (..),
-  parseOperation,
-  parseStacks,
-  parseRow,
-  combineRows,
-  parseInput,
   executeOperation,
-  zipWithPadding,
-  findTopOfStacks,
   day5_1
 ) where
 
 import qualified Data.Sequence as S
-import Data.Sequence (Seq (..))
 import Data.Foldable (toList)
-
+import Day5.Shared
-newtype StackIndex = StackIndex Int deriving (Show, Eq, Ord)
-asInt :: StackIndex -> Int
-asInt (StackIndex i) = i - 1
-
-data Operation = Operation
-                    { count :: Int
-                    , from :: StackIndex
-                    , to :: StackIndex} deriving (Show, Eq)
-
-type Content = Char
-newtype Stack = Stack [Content] deriving (Show, Eq)
-
-content :: Stack  -> [Content]
-content (Stack c) = c
-
-instance Semigroup Stack where
-  (Stack x) <> (Stack y) = Stack (x ++ y)
-
-instance Monoid Stack where
-  mempty = Stack []
-
-type Row = S.Seq Stack
-
-parseOperation :: String -> Operation
-parseOperation line = Operation {
- count = read $ parts !! 1,
-  from = StackIndex (read $ parts !! 3),
-  to = StackIndex (read $ parts !! 5)
-  }
-  where
-    parts = words line
-
-parseStacks :: [String] -> Row
-parseStacks input = foldl combineRows S.empty rows
-  where
-    rows = map parseRow input
-
-parseRow :: String -> Row
-parseRow ('[':c:']':' ':cs) = Stack [c] :<| parseRow cs
-parseRow (' ':' ':' ':' ':cs) = Stack [] :<| parseRow cs
-parseRow ['[', c, ']'] = S.singleton $ Stack [c]
-parseRow [' ', ' ', ' '] = S.singleton $ Stack []
-parseRow (' ':'1':_) = S.empty -- skip last line
-parseRow cs = error ("parseRow: unexpected Row \"" ++ cs ++ "\"")
-
-combineRows :: Row -> Row -> Row
-combineRows S.Empty row = row
-combineRows row S.Empty = row
-combineRows up down = S.fromList [x <> y | (x,y) <- zipWithPadding up down]
-
-zipWithPadding :: (Monoid a, Monoid b) => S.Seq a -> S.Seq b -> [(a,b)]
-zipWithPadding (x :<| xs)  (y :<| ys)  = (x,y) : zipWithPadding xs ys
-zipWithPadding S.Empty (y :<| ys)  = (mempty, y) : zipWithPadding S.empty ys
-zipWithPadding (x :<| xs)  S.Empty = (x, mempty) : zipWithPadding xs S.empty
-zipWithPadding S.Empty  S.Empty = []
-
-parseInput :: String -> (Row, [Operation])
-parseInput input = (parseStacks stackInput, map parseOperation (drop 1 operationInput))
-  where
-    (stackInput, operationInput) = break ("" ==) $ lines input
 
 executeOperation :: Row -> Operation -> Row
 executeOperation row op
@@ -90,13 +19,7 @@ executeOperation row op
     updatedTarget = Stack (movedContent : content targetStack)
     updatedRow = S.update (asInt $ to op) updatedTarget $ S.update (asInt $ from op) updatedOrigin row
 
-findTopOfStacks :: Row -> Seq Content
-findTopOfStacks row = head . content <$> row
-
-executeAllOperations :: Row -> [Operation] -> Row
-executeAllOperations = foldl executeOperation
-
 day5_1 :: String -> String
-day5_1 input = toList . findTopOfStacks $ executeAllOperations row operations
+day5_1 input = toList . findTopOfStacks $ foldl executeOperation row operations
   where
     (row, operations) = parseInput input

src/Day5/Part2.hs

@@ -0,0 +1,24 @@
+module Day5.Part2 (
+  execute9001Operation,
+  day5_2
+) where
+
+import qualified Data.Sequence as S
+import Data.Foldable (toList)
+import Day5.Shared
+
+execute9001Operation :: Row -> Operation -> Row
+execute9001Operation row op
+  = updatedRow 
+  where
+    originStack = row `S.index` asInt (from op)
+    targetStack = row `S.index` asInt (to op)
+    movedContent = take (count op) $ content originStack
+    updatedOrigin = Stack (drop (count op) $ content originStack)
+    updatedTarget = Stack (movedContent ++ content targetStack)
+    updatedRow = S.update (asInt $ to op) updatedTarget $ S.update (asInt $ from op) updatedOrigin row
+
+day5_2 :: String -> String
+day5_2 input = toList . findTopOfStacks $ foldl execute9001Operation row operations
+  where
+    (row, operations) = parseInput input

src/Day5/Shared.hs

@@ -0,0 +1,84 @@
+module Day5.Shared (
+  StackIndex (..),
+  Operation (..),
+  Stack (..),
+  Row,
+  Content,
+  asInt,
+  content,
+  parseOperation,
+  parseStacks,
+  parseRow,
+  combineRows,
+  parseInput,
+  zipWithPadding,
+  findTopOfStacks
+) where
+
+import qualified Data.Sequence as S
+import Data.Sequence (Seq (..))
+
+newtype StackIndex = StackIndex Int deriving (Show, Eq, Ord)
+asInt :: StackIndex -> Int
+asInt (StackIndex i) = i - 1
+
+data Operation = Operation
+                    { count :: Int
+                    , from :: StackIndex
+                    , to :: StackIndex} deriving (Show, Eq)
+
+type Content = Char
+newtype Stack = Stack [Content] deriving (Show, Eq)
+
+content :: Stack  -> [Content]
+content (Stack c) = c
+
+instance Semigroup Stack where
+  (Stack x) <> (Stack y) = Stack (x ++ y)
+
+instance Monoid Stack where
+  mempty = Stack []
+
+type Row = S.Seq Stack
+
+parseOperation :: String -> Operation
+parseOperation line = Operation {
+ count = read $ parts !! 1,
+  from = StackIndex (read $ parts !! 3),
+  to = StackIndex (read $ parts !! 5)
+  }
+  where
+    parts = words line
+
+parseStacks :: [String] -> Row
+parseStacks input = foldl combineRows S.empty rows
+  where
+    rows = map parseRow input
+
+parseRow :: String -> Row
+parseRow ('[':c:']':' ':cs) = Stack [c] :<| parseRow cs
+parseRow (' ':' ':' ':' ':cs) = Stack [] :<| parseRow cs
+parseRow ['[', c, ']'] = S.singleton $ Stack [c]
+parseRow [' ', ' ', ' '] = S.singleton $ Stack []
+parseRow (' ':'1':_) = S.empty -- skip last line
+parseRow cs = error ("parseRow: unexpected Row \"" ++ cs ++ "\"")
+
+combineRows :: Row -> Row -> Row
+combineRows S.Empty row = row
+combineRows row S.Empty = row
+combineRows up down = S.fromList [x <> y | (x,y) <- zipWithPadding up down]
+
+zipWithPadding :: (Monoid a, Monoid b) => S.Seq a -> S.Seq b -> [(a,b)]
+zipWithPadding (x :<| xs)  (y :<| ys)  = (x,y) : zipWithPadding xs ys
+zipWithPadding S.Empty (y :<| ys)  = (mempty, y) : zipWithPadding S.empty ys
+zipWithPadding (x :<| xs)  S.Empty = (x, mempty) : zipWithPadding xs S.empty
+zipWithPadding S.Empty  S.Empty = []
+
+parseInput :: String -> (Row, [Operation])
+parseInput input = (parseStacks stackInput, map parseOperation (drop 1 operationInput))
+  where
+    (stackInput, operationInput) = break ("" ==) $ lines input
+
+
+findTopOfStacks :: Row -> Seq Content
+findTopOfStacks row = head . content <$> row

test/Day5Spec.hs

@@ -6,6 +6,8 @@ import Text.Heredoc
 import qualified Data.Sequence as S
 
 import Day5.Part1
+import Day5.Part2
+import Day5.Shared
 
 inputPart1 :: String
 inputPart1 = [str|    [D]
@@ -72,4 +74,11 @@ spec =
          findTopOfStacks row `shouldBe` S.fromList "NDP"
       it "solves the demo" $ do
          day5_1 inputPart1 `shouldBe` "CMZ"
+    describe "Part1" $ do
+      it "executes 9001 operations on a row" $ do
+        let op = Operation { count = 2, from = StackIndex 2, to = StackIndex 3}
+        let row = S.fromList [Stack "NZ", Stack "DCM", Stack "P"]
+        execute9001Operation row op `shouldBe` S.fromList [Stack "NZ", Stack "M", Stack "DCP"]
+      it "solves the demo" $ do
+         day5_2 inputPart1 `shouldBe` "MCD"