AoC 2022 day 5 part 1

day5a.hs

type Column = Int
type Crate = Char
type Stacks = Map.Map Column [Crate]
data Move = Move Int Column Column deriving (Show, Eq)

parse :: [String] -> (Stacks, [Move])
parse ls =
  let
    [stackDesc, moveDesc] = ls & splitOn [""]
    stacks = foldl' stackLine Map.empty stackDesc   
    moves = mapMaybe (quickParse parseMove) moveDesc
  in (stacks, moves)
  where
  stackLine :: Stacks -> String -> Stacks
  stackLine stack0 line =
    let
      discs = (line & chunksOf 4) `zip` [1..]
      stack1 = foldl' parseDisc stack0 discs
    in stack1
  parseDisc :: Stacks -> (String, Column) -> Stacks
  parseDisc stack0 ('[' : c : ']' : _, col) = Map.alter (addDisc c) col stack0
  parseDisc stack0 _ = stack0
  addDisc :: Crate -> Maybe [Crate] -> Maybe [Crate]
  addDisc c Nothing = Just [c]
  addDisc c (Just cs) = Just (cs ++ [c])


parseMove :: ReadP Move
parseMove =
  Move <$>
    (string "move " *> natParser <&> fromIntegral) <*>
    (string " from " *> natParser <&> fromIntegral) <*>
    (string " to " *> natParser <* eof <&> fromIntegral)

applyMove :: Stacks -> Move -> Stacks
applyMove stacks (Move n f t) =
  let
    from = stacks Map.! f
    to = stacks Map.! t
    s1 = Map.insert f (drop n from) stacks
    s2 = Map.insert t ((take n from & reverse) ++ to) s1
  in s2


topCrates :: Stacks -> [Crate]
topCrates stacks = Map.toAscList stacks
                 & mapMaybe (\(_, cs) -> maybeHead cs)
  where
  maybeHead [] = Nothing
  maybeHead (c:cs) = Just c
                 


day5 ls =
  let
    (stacks0, moves) = parse ls
    stacks1 = foldl applyMove stacks0 moves
  in topCrates stacks1