結果

問題 No.585 工夫のないパズル
ユーザー くれちーくれちー
提出日時 2017-10-29 21:53:57
言語 Haskell
(9.8.2)
結果
CE  
(最新)
AC  
(最初)
実行時間 -
コード長 4,015 bytes
コンパイル時間 289 ms
コンパイル使用メモリ 147,584 KB
最終ジャッジ日時 2024-11-14 20:15:26
合計ジャッジ時間 799 ms
ジャッジサーバーID
（参考情報） 		judge4 / judge5
このコードへのチャレンジ
（要ログイン）
コンパイルエラー時のメッセージ・ソースコードは、提出者また管理者しか表示できないようにしております。（リジャッジ後のコンパイルエラーは公開されます）
ただし、clay言語の場合は開発者のデバッグのため、公開されます。

コンパイルメッセージ
Loaded package environment from /home/judge/.ghc/x86_64-linux-9.8.2/environments/default
[1 of 2] Compiling Main             ( Main.hs, Main.o )

Main.hs:98:9: error: [GHC-07626]
    Parse error in pattern: move2 In a function binding for the ‘@’ operator.
                            Perhaps you meant an as-pattern, which must not be surrounded by whitespace
   |
98 |         move2 (sr, sc) t @ (tr, tc) = do
   |         ^^^^^^^^^^^^^^^^

ソースコード

diff # 

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
0