{-# Language QuasiQuotes, ImportQualifiedPost #-}
{-|
Module      : Main
Description : Day 5 solution
Copyright   : (c) Eric Mertens, 2022
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2022/day/5>

>>> :{
:main +
    "    [D]    \n\
    \[N] [C]    \n\
    \[Z] [M] [P]\n\
    \ 1   2   3 \n\
    \\n\
    \move 1 from 2 to 1\n\
    \move 3 from 1 to 3\n\
    \move 2 from 2 to 1\n\
    \move 1 from 1 to 2\n"
:}
CMZ
MCD

-}
module Main where

import Data.List (transpose)
import Data.Maybe (catMaybes)
import Data.Map (Map)
import Data.Map qualified as Map

import Advent (format)

main :: IO ()
IO ()
main =
 do ([[Maybe Char]]
toppart, [Char]
labels, [(Int, Char, Char)]
commands) <- [format|2022 5
        ((   |[%c])& %n)*
        ( %c )& %n
        %n
        (move %u from %c to %c%n)*|]
    let stacks :: Map Char [Char]
stacks = [(Char, [Char])] -> Map Char [Char]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Char] -> [[Char]] -> [(Char, [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Char]
labels (([Maybe Char] -> [Char]) -> [[Maybe Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Maybe Char] -> [Char]
forall a. [Maybe a] -> [a]
catMaybes ([[Maybe Char]] -> [[Maybe Char]]
forall a. [[a]] -> [[a]]
transpose [[Maybe Char]]
toppart)))
    let solve :: ([Char] -> [Char] -> [Char]) -> [Char]
solve [Char] -> [Char] -> [Char]
f = ([Char] -> Char) -> [[Char]] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Char
forall a. HasCallStack => [a] -> a
head (Map Char [Char] -> [[Char]]
forall k a. Map k a -> [a]
Map.elems ((Map Char [Char] -> (Int, Char, Char) -> Map Char [Char])
-> Map Char [Char] -> [(Int, Char, Char)] -> Map Char [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (([Char] -> [Char] -> [Char])
-> Map Char [Char] -> (Int, Char, Char) -> Map Char [Char]
forall k a.
Ord k =>
([a] -> [a] -> [a]) -> Map k [a] -> (Int, k, k) -> Map k [a]
apply [Char] -> [Char] -> [Char]
f) Map Char [Char]
stacks [(Int, Char, Char)]
commands))
    [Char] -> IO ()
putStrLn (([Char] -> [Char] -> [Char]) -> [Char]
solve (([Char] -> [Char] -> [Char]) -> [Char] -> [Char] -> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([Char] -> Char -> [Char]) -> [Char] -> [Char] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Char -> [Char] -> [Char]) -> [Char] -> Char -> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)))))
    [Char] -> IO ()
putStrLn (([Char] -> [Char] -> [Char]) -> [Char]
solve [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++))

apply :: Ord k => ([a] -> [a] -> [a]) -> Map k [a] -> (Int, k, k) -> Map k [a]
apply :: forall k a.
Ord k =>
([a] -> [a] -> [a]) -> Map k [a] -> (Int, k, k) -> Map k [a]
apply [a] -> [a] -> [a]
f Map k [a]
stacks (Int
n, k
fr, k
to) =
    case (Maybe [a] -> ([a], Maybe [a]))
-> k -> Map k [a] -> ([a], Map k [a])
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (([a] -> ([a], [a])) -> Maybe [a] -> ([a], Maybe [a])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n)) k
fr Map k [a]
stacks of
        ([a]
a, Map k [a]
m) -> ([a] -> [a]) -> k -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ([a] -> [a] -> [a]
f [a]
a) k
to Map k [a]
m