Day 5 Part 1

src/Day5/Part1.hs

@@ -0,0 +1,102 @@
+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)
+
+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
+  | count op == 1 = updatedRow
+  | otherwise = executeOperation updatedRow (Operation { count = count op - 1, from = from op, to = to op })
+  where
+    originStack = row `S.index` asInt (from op)
+    targetStack = row `S.index` asInt (to op)
+    movedContent = head $ content originStack
+    updatedOrigin = Stack (drop 1 $ content originStack)
+    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
+  where
+    (row, operations) = parseInput input