103 lines
3.1 KiB
Haskell
103 lines
3.1 KiB
Haskell
|
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
|