import Data.Char (ord) import Data.List (elemIndex, transpose) import Data.Maybe (fromJust) import Control.Monad (replicateM) import Control.Monad.State import Control.Monad.Writer infixl 0 |> (|>) :: a -> (a -> c) -> c x |> f = f x infixl 9 .> (.>) :: (c -> b) -> (b -> a) -> c -> a f .> g = \ x -> g (f x) -- rotate 2 [0, 1, 2, 3, 4] => [3, 4, 0, 1, 2] -- n >= 0 rotate :: Int -> [a] -> [a] rotate n xs = let l = length xs - n in drop l xs ++ take l xs newtype Puzzle = Puzzle { getRows :: [[Int]] } instance Show Puzzle where show = let f x = (if x < 10 then "0" else "") ++ show x in getRows .> map (map f .> unwords) .> unlines getColumns :: Puzzle -> [[Int]] getColumns = getRows .> transpose fromRows :: [[Int]] -> Puzzle fromRows = Puzzle fromColumns :: [[Int]] -> Puzzle fromColumns = transpose .> Puzzle at :: (Int, Int) -> Puzzle -> Int at (r, c) p = getRows p !! r !! c getIndex :: Int -> Puzzle -> (Int, Int) getIndex x p = let i = getRows p |> concat |> elemIndex x |> fromJust in (i `div` 4, i `mod` 4) splitAtRow :: Int -> Puzzle -> ([[Int]], [Int], [[Int]]) splitAtRow r = do l <- getRows return (l |> take r, l !! r, l |> drop (succ r)) splitAtColumn :: Int -> Puzzle -> ([[Int]], [Int], [[Int]]) splitAtColumn c = do l <- getColumns return (l |> take c, l !! c, l |> drop (succ c)) data Operate = R Int Int | C Int Int deriving Show type Puzzler = StateT Puzzle (Writer [Operate]) () runPuzzler :: Puzzler -> Puzzle -> (Puzzle, [Operate]) runPuzzler s = execStateT s .> runWriter -- 列 c を n 下へ rotate down :: Int -> Int -> Puzzler down c n = when (n > 0) $ do lift $ tell [C c n] (c0, c1, c2) <- gets $ splitAtColumn c put $ fromColumns $ c0 ++ (c1 |> rotate n |> pure) ++ c2 -- 行 r を n 右へ rotate right :: Int -> Int -> Puzzler right r n = when (n > 0) $ do lift $ tell [R r n] (r0, r1, r2) <- gets $ splitAtRow r put $ fromRows $ r0 ++ (r1 |> rotate n |> pure) ++ r2 -- 行 sr より上を崩さずに (sr, sc) を (tr, tc) へ移動 -- tr <= sr && tr <= 2 move :: (Int, Int) -> (Int, Int) -> Puzzler move s @ (sr, sc) t @ (tr, tc) | s == t = return () | sr == tr = move1 s t | sc == tc = move2 s t | otherwise = move0 s t where -- 基本操作 move0 (sr, sc) (tr, tc) = do down tc (sr - tr) right sr ((tc - sc) `mod` 4) down tc (4 - (sr - tr)) -- 移動元と移動先の行が同じ場合 move1 (sr, sc) (tr, tc) = do down sc 1 down tc 1 right (sr + 1) ((tc - sc) `mod` 4) down sc 3 down tc 3 -- 移動元と移動先の列が同じ場合 move2 (sr, sc) t @ (tr, tc) = do right sr 1 move0 (sr, sc + 1) t -- 他のマスを崩さずに (r, c) と (r, c + 1) を交換 swap :: (Int, Int) -> Puzzler swap (r, c) = do let c' = (c + 2) `mod` 4 down c' 1 right r 1 down c' 3 right r 2 down c' 1 right r 1 down c' 3 right r 1 solve :: Puzzler solve = do forM_ [(r, c) | r <- [0 .. 2], c <- [0 .. 3]] solve0 solve1 where -- 上から 3 行を揃える solve0 (r, c) = do s <- gets $ getIndex (r * 4 + c) move s (r, c) -- 最後の行を揃える solve1 = do -- 12 (M) を左端へ移動 (_, c) <- gets $ getIndex 12 right 3 ((4 - c) `mod` 4) -- 右から 3 マスを bubble sort forM_ [2, 1, 2] $ \ c -> do x1 <- gets $ at (3, c) x2 <- gets $ at (3, c + 1) when (x1 > x2) $ swap (3, c) main :: IO () main = replicateM 4 getLine >>= getRows .> fromRows .> getAns .> mapM_ putStrLn where getRows = (map . map) (\ c -> ord c - ord 'A') getAns = let os = runPuzzler solve .> snd in (++) <$> os .> length .> show .> pure <*> os .> map show