結果

問題 No.179 塗り分け
コンテスト
ユーザー A_kirisaki
提出日時 2017-05-01 13:51:12
言語 Haskell
(9.10.1)
結果
AC  
実行時間 164 ms / 3,000 ms
コード長 2,435 bytes
コンパイル時間 8,233 ms
コンパイル使用メモリ 218,500 KB
実行使用メモリ 7,808 KB
最終ジャッジ日時 2024-07-23 14:42:26
合計ジャッジ時間 9,901 ms
ジャッジサーバーID
（参考情報） 		judge5 / judge4
このコードへのチャレンジ
（要ログイン）
ファイルパターン 結果
sample AC * 6
other AC * 40
権限があれば一括ダウンロードができます
コンパイルメッセージ
Loaded package environment from /home/judge/.ghc/x86_64-linux-9.8.2/environments/default
[1 of 2] Compiling Main             ( Main.hs, Main.o )
[2 of 2] Linking a.out

ソースコード

diff # 

import Data.Array.Unboxed
import Data.List
import Data.Maybe

type Point = (Int,Int)
type Bitmap = UArray Point Bool

-- テキスト前処理
cropText :: [String] -> [String]
cropText strs = let
  h = length strs
  w = minimum $ map length strs
  indices = map (elemIndices '#') strs
  top = (length $ takeWhile (==[]) indices) 
  bottom = h - (length $ takeWhile (==[]) $ reverse indices)
  left = minimum $ concat indices 
  right = (maximum $ concat indices) +1
  in
     map (drop left) $ map (take right)(drop top $ take bottom strs)
  
textBitmap :: [String] -> Bitmap
textBitmap []  = listArray ((0,0),(0,0)) [False] -- 強引な処理
textBitmap strs  = let
  toBool '#' = True
  toBool '.' = False
  ixs = [(x,y) | y<-[0..(length strs)-1], x<-[0..(maximum $ map length strs)-1]]
  imax = maximum ixs
  in
    array ((0,0),imax) (zip ixs (map toBool $ concat strs))

-- ピクセル移動
-- 失敗したらNothing
shiftPixel :: Bitmap -> Point -> Point -> Maybe Bitmap
shiftPixel b src dest 
  | ps == False && pd == False = Just b
  | ps == False && pd == True  = Just b
  | ps == True  && pd == False = Nothing
  | ps == True  && pd == True  =
      Just $ b // [(src, False), (dest, False)]
  where
    ps = b ! src
    pd = b ! dest

-- 再帰的にチェック
-- 失敗したら探索打ち切り
checkPixels :: Maybe Bitmap -> [(Point,Point)] -> Bool
checkPixels Nothing _ = False
checkPixels (Just b) [] = not $ or $ elems b
checkPixels (Just b) (p:ps) = let
  (src,dest) = p
  b' = shiftPixel b src dest 
  in
    checkPixels b' ps

-- 移動量から移動前後の位置リストを作り探索
checkOneCase :: Bitmap -> Point -> Bool
checkOneCase b (x,y) = let
  (x',y') = maximum $ indices b
  ps = if x >= 0
       then [((xa,ya),(xa+x,ya+y)) | ya <- [0..y'-y], xa <- [0..x'-x]]
       else [((xa,ya),(xa+x,ya+y)) | ya <- [0..y'-y], xa <- [abs x..x']]
  in
    checkPixels (Just b) ps

-- 取りうる移動量全てに対し探索
solveNuriwake :: Bitmap -> Bool
solveNuriwake b = let
  (w,h) = maximum $ indices b 
  ss = [(x,y) | y <- [0..h], x <- [-w..w], not(x<=0 && y==0)]
  n = length $ filter id $ elems b
  in
    if  odd n || n == 0
    then False
    else or $ map (checkOneCase b)  ss
  
main = do
  getLine -- 1行目のサイズは必要ないので無視
  str <- getContents
  let problem = textBitmap . cropText $ lines str
  if solveNuriwake problem
    then putStr "YES"
    else putStr "NO"
0